commit aa25e9347fd008296aa9c34c894954e8089a9954 Author: dsainty Date: Mon Jun 17 21:49:12 2024 +1000 First pass at adding key files diff --git a/README.md b/README.md new file mode 100644 index 0000000..f81ba62 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +All the legacy code 'n' stuff from the "home" directory of the legacy server, for all things Gossamer Forums related. diff --git a/forum.slowtwitch.com/cgi-bin b/forum.slowtwitch.com/cgi-bin new file mode 120000 index 0000000..0194eb5 --- /dev/null +++ b/forum.slowtwitch.com/cgi-bin @@ -0,0 +1 @@ +/var/home/slowtwitch/site/forum.slowtwitch.com/cgi-bin \ No newline at end of file diff --git a/forum.slowtwitch.com/modperl.conf b/forum.slowtwitch.com/modperl.conf new file mode 100644 index 0000000..ca9de23 --- /dev/null +++ b/forum.slowtwitch.com/modperl.conf @@ -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 + + Options FollowSymLinks + AllowOverride None + + +# Document Root + + Options All -Indexes + AllowOverride All + + +# Disallow any attempts at viewing .ht* files + + Order allow,deny + Deny from all + Satisfy All + + +# Setup /icons/ alias +Alias /icons/ /var/httpd/icons/ + + Options MultiViews + AllowOverride None + Order allow,deny + Allow from all + + +# View server status information + + # 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 + + +# View perl info + + # 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 + + +# 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/ + + Order Allow,Deny + Allow From All + AllowOverride All + Options +ExecCGI + + SetHandler perl-script + PerlHandler Apache::Registry + PerlSendHeader On + + +# 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/ + + Order Allow,Deny + Allow From All + AllowOverride All + Options +ExecCGI + + SetHandler perl-script + PerlHandler Apache::Registry + PerlSendHeader On + + +# vim:syn=apache:sw=4:et + + diff --git a/forum.slowtwitch.com/modperl.conf.bak b/forum.slowtwitch.com/modperl.conf.bak new file mode 100644 index 0000000..10b4a8f --- /dev/null +++ b/forum.slowtwitch.com/modperl.conf.bak @@ -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 + + Options FollowSymLinks + AllowOverride None + + +# Document Root + + Options All -Indexes + AllowOverride All + + +# Disallow any attempts at viewing .ht* files + + Order allow,deny + Deny from all + Satisfy All + + +# Setup /icons/ alias +Alias /icons/ /var/httpd/icons/ + + Options MultiViews + AllowOverride None + Order allow,deny + Allow from all + + +# View server status information + + # 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 + + +# View perl info + + # 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 + + +# 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/ + + Order Allow,Deny + Allow From All + AllowOverride All + Options +ExecCGI + + SetHandler perl-script + PerlHandler Apache::Registry + PerlSendHeader On + + +# 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/ + + Order Allow,Deny + Allow From All + AllowOverride All + Options +ExecCGI + + SetHandler perl-script + PerlHandler Apache::Registry + PerlSendHeader On + + +# vim:syn=apache:sw=4:et + + diff --git a/forum.slowtwitch.com/modperl.mime_types b/forum.slowtwitch.com/modperl.mime_types new file mode 100644 index 0000000..16c8cbd --- /dev/null +++ b/forum.slowtwitch.com/modperl.mime_types @@ -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 . + +# 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 diff --git a/forum.slowtwitch.com/modperl_startup.pl b/forum.slowtwitch.com/modperl_startup.pl new file mode 100755 index 0000000..38d9f8f --- /dev/null +++ b/forum.slowtwitch.com/modperl_startup.pl @@ -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; + diff --git a/forum.slowtwitch.com/modperl_startup.pl.bak b/forum.slowtwitch.com/modperl_startup.pl.bak new file mode 100755 index 0000000..38d9f8f --- /dev/null +++ b/forum.slowtwitch.com/modperl_startup.pl.bak @@ -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; + diff --git a/forum.slowtwitch.com/modperlctl b/forum.slowtwitch.com/modperlctl new file mode 100755 index 0000000..355b31c --- /dev/null +++ b/forum.slowtwitch.com/modperlctl @@ -0,0 +1,4 @@ +#!/bin/sh + +exec /usr/sbin/service modperl "$*" forum.slowtwitch.com + diff --git a/site/common/bin/minify.cgi b/site/common/bin/minify.cgi new file mode 100755 index 0000000..f92c368 --- /dev/null +++ b/site/common/bin/minify.cgi @@ -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, "
";
+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";
+}
diff --git a/site/forum.slowtwitch.com/cgi-bin/gforum.cgi b/site/forum.slowtwitch.com/cgi-bin/gforum.cgi
new file mode 100755
index 0000000..0efbbe3
--- /dev/null
+++ b/site/forum.slowtwitch.com/cgi-bin/gforum.cgi
@@ -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);
diff --git a/site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess b/site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
new file mode 100644
index 0000000..2fb0232
--- /dev/null
+++ b/site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
@@ -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
diff --git a/site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi b/site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
new file mode 100755
index 0000000..7546a53
--- /dev/null
+++ b/site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
@@ -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 "Poll Admin<$FONT>";
+}
+
+sub nav {
+    print qq!
+Poll: Add Poll | List Poll
+!;
+#
Quiz: Add Quiz | List Quiz
+} + +sub footer { + print ""; +} + +sub include_form { +# ------------------------------------------------------------------- +# + my $val = shift || {}; + my $option = shift || $MAX; + my $output = qq~
+ + \n~; + + $output .= qq~

<$FONT color="red">$val->{error}

~ if $val->{error}; + + $output .= qq~ + Question:

\n + Description:

\n + Answers Options:
+ ~; + my $i = 1; + my $select = qq~  ~; + if (!$val->{poll_type}) { + $output .= qq~Votes:
\n~; + } + $output .= qq~\n~; + $output .= "
"; + $select .= qq~\n~; + $i++; + } + if ($IN->param('num_answers') > $i) { + foreach ($i .. $IN->param('num_answers')) { + $output .= qq~Option $_:  ~; + if (!$val->{poll_type}) { + $output .= qq~Votes:
\n~; + } + $output .= "
"; + $select .= qq~\n~; + } + } + $i += 2; + } + else { + foreach (1 .. $option) { + my $ans = $val->{'poll_answer_answer_' . $_}; + $output .= qq~Option $_:  ~; + if (!$val->{poll_type}) { + $output .= qq~Votes: \n~; + } + $output .= "
"; + $select .= qq~\n~; + } + } + $select .= ""; + if ($val->{poll_type} == 1) { + $output .= qq~Right Answer: $select
\n~; + } + $output .= qq~Total Votes:

\n~; + $output .= $val->{poll_id} ? + qq~ Want to add more options?
~ : + qq~~; + + 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 "
" . Dumper($cgi) . "
"; + my $db = $DB->table('Poll'); + my $ans_db = $DB->table('PollAnswer'); + my $sth = $db->query_sth($cgi); + my $output; + + if ($msg) { + $output .= "

$msg

"; + } + my $i=1; + my $correct = ""; + while (my $row = $sth->fetchrow_hashref()) { + my $date = $row->{poll_date}; + $output .= qq~

+ ~; + 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~ + + + + + ~; + } + if ($row->{poll_type}) { + $output .= qq~~; + $output .= qq~~; + } + else { + $output .= qq~~; + } + $output .= qq~
<$FONT>$i.) $row->{poll_question} (posted on $date)
<$FONT>Description: $row->{poll_text}
+ <$FONT> + $poll_answer->{poll_answer_answer} + + <$FONT> ~; + if ($poll_answer->{poll_answer_percentage}) { + my $width = $poll_answer->{poll_answer_percentage} * 4; + $output .= qq~~; + } + else { + $output .= qq~~; + } + $output .= qq~$poll_answer->{poll_answer_votes} / $poll_answer->{poll_answer_percentage} % +
<$FONT>The Correct Answer is: $correct
<$FONT>Total Answered: $row->{poll_votes}
<$FONT>Total Votes: $row->{poll_votes}
<$FONT> Edit | ~; + $output .= $row->{poll_enabled} ? + qq~ Disable ~ : + qq~ Enable~ ; + $output .= $row->{poll_home} ? + qq~| Don't Show this on Home Page~ : + qq~| Show this on Home Page~ ; + $output .= qq~
~; + $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."); +} diff --git a/site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi b/site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi new file mode 100755 index 0000000..fa7ef84 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi @@ -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(); + } + +} + diff --git a/site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi b/site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi new file mode 100755 index 0000000..3062301 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi @@ -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(); + diff --git a/site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi b/site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi new file mode 100755 index 0000000..712d7d1 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi @@ -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; +} diff --git a/site/forum.slowtwitch.com/cgi-bin/threads.cgi b/site/forum.slowtwitch.com/cgi-bin/threads.cgi new file mode 100755 index 0000000..d2ed2e4 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/threads.cgi @@ -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!

!; + } + print qq!
$html
!; +} diff --git a/site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess new file mode 100644 index 0000000..2fb0232 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess @@ -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 diff --git a/site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi new file mode 100755 index 0000000..ddea9f9 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi @@ -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{Ticker Admin}; + + # 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 "

" . $s{error} . "

"; + } + + # 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{

} . $s{title} . qq{

+
+ + +
+ +
+ +
+
+ }; + + # provide a way to get back to the create interface: + if($s{action} =~ /update/) { + print qq{Create a ticker instead.}; + } + + # Now print the entire list of all tickers. + print qq{

Current tickers:

}; + + + # 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 ""; + print ""; + foreach my $k (@{$s{data}}) { + my $id = $k->{ticker_id}; + my $msg = $k->{ticker_text}; + my $link = $k->{ticker_link}; + print qq{"; + } + print "
IDMessageLink
$id + Delete + Update} . + $msg . "" . + qq{} . + $link . "
"; + } + print qq{}; +} + diff --git a/site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi new file mode 100755 index 0000000..96398a7 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi @@ -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(); diff --git a/site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi b/site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi new file mode 100755 index 0000000..5256555 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi @@ -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'); + diff --git a/site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi b/site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi new file mode 100755 index 0000000..1a7c813 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi @@ -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(); diff --git a/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/.htaccess b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/.htaccess new file mode 100644 index 0000000..2fb0232 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/.htaccess @@ -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 diff --git a/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi new file mode 100755 index 0000000..d8c8498 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi @@ -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{TickerAd Admin}; + + # 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 "

" . $s{error} . "

"; + } + + # 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{

} . $s{title} . qq{

+
+ + +
+ +
+ +
+
+ }; + + # provide a way to get back to the create interface: + if($s{action} =~ /update/) { + print qq{Create a ticker instead.}; + } + + # Now print the entire list of all tickers. + print qq{

Current tickers:

}; + + + # 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 ""; + print ""; + foreach my $k (@{$s{data}}) { + my $id = $k->{ticker_id}; + my $msg = $k->{ticker_text}; + my $link = $k->{ticker_link}; + print qq{"; + } + print "
IDMessageLink
$id + Delete + Update} . + $msg . "" . + qq{} . + $link . "
"; + } + print qq{}; +} + diff --git a/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi new file mode 100755 index 0000000..96398a7 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi @@ -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(); diff --git a/site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi b/site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi new file mode 100755 index 0000000..5256555 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi @@ -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'); + diff --git a/site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi b/site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi new file mode 100755 index 0000000..1a7c813 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi @@ -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(); diff --git a/site/forum.slowtwitch.com/cgi-bin/toggle.cgi b/site/forum.slowtwitch.com/cgi-bin/toggle.cgi new file mode 100755 index 0000000..59583b6 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/toggle.cgi @@ -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/
\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/
\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 (click to unhide)~; + } + else { + $DB->table('User')->update({ user_show_racetags => 1 }, { user_id => $USER->{user_id} }); + print $IN->header . qq~Viewable (click to hide)~; + } + } +} + +1; diff --git a/site/forum.slowtwitch.com/cgi-bin/widget.cgi b/site/forum.slowtwitch.com/cgi-bin/widget.cgi new file mode 100755 index 0000000..1c6a639 --- /dev/null +++ b/site/forum.slowtwitch.com/cgi-bin/widget.cgi @@ -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] }); + } +} diff --git a/site/forum.slowtwitch.com/www/static/fileman/help/command-perl.gif b/site/forum.slowtwitch.com/www/static/fileman/help/command-perl.gif new file mode 100644 index 0000000..22eeb98 Binary files /dev/null and b/site/forum.slowtwitch.com/www/static/fileman/help/command-perl.gif differ diff --git a/site/glist/lib/GList.pm b/site/glist/lib/GList.pm new file mode 100644 index 0000000..a66e11d --- /dev/null +++ b/site/glist/lib/GList.pm @@ -0,0 +1,1251 @@ +# ================================================================== +# Gossamer List - enhanced mailing list management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : +# Revision : $Id: GList.pm,v 1.69 2004/10/14 22:57:50 bao Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# Redistribution in part or in whole strictly prohibited. Please +# see LICENSE file for full details. +# ================================================================== +# + +package GList; +# ================================================================== + +use 5.004_04; +use strict; +use GList::Custom; # Empty module for end-users to modify, if special code is + # required. Won't be overwritten when upgrading. + +use vars qw($VERSION $DEBUG $IN $DB $CFG $USER $GLOBALS $GLOB_NO_SUBS $LANGUAGE $LANG_TPL $error @ISA @EXPORT_OK %EXPORT_TAGS $MN_SELECTED); +use GT::Base qw/:all/; +use GT::CGI; +use GT::Config; +use GT::Delay; +use GT::Template; +use GT::Plugins; +use GList::Config; +require Exporter; + +$DEBUG = 0; +$VERSION = '1.1.1'; + +use constants + READ_SIZE => 65_536, + + ADMINISTRATOR => 1, + LIMITED_USER => 2, + UNLIMITED_USER => 3, + UNVALIDATED_USER => 4, + + TRACK_OPEN_HTML => < + +
+HTML + + TRACK_OPEN_HTML_NOIFRAME => < +
+HTML + + TRACK_CLICK_URL => "<%cgi_url%>/glist.cgi?do=user_click;mailing=<%mailing%>"; + + +@ISA = 'Exporter'; +@EXPORT_OK = qw/ + $VERSION $MOD_PERL $DEBUG $IN $DB $CFG $USER $GLOBALS $LANGUAGE $MN_SELECTED + ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL +/; +%EXPORT_TAGS = ( + all => \@EXPORT_OK, + objects => [qw/$IN $DB $CFG $USER $MN_SELECTED/], + user_type => [qw/ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER/], + tracks => [qw/TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL/] +); + +my $basic_tables; + +sub init { +# ----------------------------------------------------------------------------- +# This subroutine should be called on every request with a single argument: the +# path to the private library directory. +# + +# If called as a method, discard the class/object: + shift if @_ and UNIVERSAL::isa($_[0], __PACKAGE__); + my $lib_path = shift || '.'; + + if (PERSIST) { + GT::SQL->reset_env() if $INC{'GT/SQL.pm'}; + GT::Plugins->reset_env(); + GT::CGI->reset_env(); + } + +# Get our config object. + $CFG = GList::Config->new($lib_path); + + my $debug = $CFG->{debug_level} || $DEBUG; + +# create input and sql objects + $IN = GT::CGI->new(); + + if ($DB and not ref $DB eq 'GT::Delay') { + $DB = GT::SQL->new({ + def_path => "$CFG->{priv_path}/defs", + cache => 1, + debug => $debug + }); + } + else { + $DB = GT::Delay( + 'GT::SQL' => 'HASH', + { + def_path => "$CFG->{priv_path}/defs", + cache => 1, + debug => $debug + } + ); + } + +# Set plugin debug level. + $GT::Plugins::DEBUG = $debug; + + $USER = $GLOBALS = $GLOB_NO_SUBS = $LANGUAGE = $LANG_TPL = $basic_tables = undef; +} + +sub init_user { +# ----------------------------------------------------------------------------- +# Check to see if the request is for a valid user, if so, set $USER to the +# user. +# + +# Authenticate the user. + require GList::Authenticate; + GList::Authenticate::auth('init'); + + $USER = undef; + + my $username = shift || $IN->param('username') || undef; + my $password = shift || $IN->param('password') || undef; + +# Validate the username, either through logging on, or checking the +# session. + my ($valid_user, $session_id, $use_cookie); + if (defined $username && defined $password) { + unless (test_connection()) { # Database connection is failed + if ( GList::Authenticate::auth('admin_valid_user', { username => $username, password => $password }) ) { + $USER->{username} = $username; + $USER->{usr_type} = ADMINISTRATOR; + return $USER; + } + } + elsif (GList::Authenticate::auth('valid_user', { username => $username, password => $password })) { + $valid_user = $username; + } + } + else { + unless (test_connection()) { # Database connection is failed + my $results = GList::Authenticate::auth('admin_valid_session'); + if ($results) { + $USER = $results; + $USER->{usr_type} = ADMINISTRATOR; + return $USER; + } + return; + } + my $results = GList::Authenticate::auth('valid_session'); + $valid_user = $results->{user_name}; + $session_id = $results->{session_id}; + $use_cookie = $results->{use_cookie}; + } + return if !$valid_user; + +# We have a valid_user, now let's get the user from database + $USER = GList::Authenticate::auth('get_user', { username => $valid_user }); + return 1 if !$USER; + + if ($CFG->{signup_email_validate} and $USER->{usr_validate_code}) { + return 2; + } + + if ($CFG->{signup_admin_validate} and $USER->{usr_type} == UNVALIDATED_USER) { + return 3; + } + + $USER->{use_cookie} = $use_cookie; + $USER->{session_id} = $session_id; + + return $USER; +} + +sub test_connection { +# ----------------------------------------------------------------------------- +# Test the database connection by trying to establish a connection. Returns +# 1 on success, nothing on connection error. In addition to the database +# connection, this also makes sure that the Users and Users_Sessions tables +# are working, since you need them at a minimum to get to the SQL setup page. +# + $DB->driver or return; + GT::SQL::Table->new(connect => $DB->{connect})->connect or return; + unless ($basic_tables) { + defined $DB->table('Users')->count({ usr_username => undef }) or return; + defined $DB->table('Users_Sessions')->count({ session_id => undef }) or return; + $basic_tables++; + } + + return 1; +} + +sub environment { +# -------------------------------------------------------------------- +# Return HTML formatted environment for error messages. +# + my $info = '
';
+
+# Stack trace.
+    my $i = 0;
+    $info .= "Stack Trace\n======================================\n";
+    $info .= GT::Base::stack_trace('GList', 1);
+    $info .= "\n\n";
+
+# Print GT::SQL error if it exists.
+    $info .= "System Information\n======================================\n";
+    $info .= "Perl Version: $]\n";
+    $info .= "GList SQL Version: $GList::VERSION\n" if ($GList::VERSION);
+    $info .= "DBI.pm Version: $DBI::VERSION\n" if ($DBI::VERSION);
+    $info .= "Running under mod_perl: " . (MOD_PERL ? "Yes (version " . MOD_PERL . ")" . (MOD_PERL >= 1.99 ? ', mod_perl 2 detected' : '') : "No") . "\n";
+    $info .= "Running under SpeedyCGI: " . (SPEEDY ? "Yes (version " . SPEEDY . ")" : "No") . "\n";
+    $info .= "GT::SQL::error = $GT::SQL::error\n" if ($GT::SQL::error);
+    $info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
+    $info .= "\$\@: $@\n" if ($@);
+    $info .= "\n";
+
+# CGI Parameters and Cookies.
+    if (ref $IN eq 'GT::CGI') {
+        if ($IN->param) {
+            $info .= "CGI INPUT\n======================================\n";
+            foreach (sort $IN->param) { $info .= "$_ => " . $IN->param($_) . "\n"; }
+            $info .= "\n\n";
+        }
+        if ($IN->cookie) {
+            $info .= "CGI Cookies\n======================================\n";
+            foreach (sort $IN->cookie) { $info .= "$_ => " . $IN->cookie($_) . "\n"; }
+            $info .= "\n\n";
+        }
+    }
+
+# Environement info.
+    $info  .= "ENVIRONMENT\n======================================\n";
+    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
+    $info .= "
"; + + return $info; +} + +sub display { +# ----------------------------------------------------------------- +# Returns a specified template parsed. +# + my ($template, $args) = @_; + + my $template_set = $IN->param('t') || $CFG->{template_set}; + my $template_dir = "$CFG->{priv_path}/templates/$template_set"; + my $http = $IN->url(absolute => 0, query_string => 0); + +# Add config vars. + foreach my $key (keys %$CFG) { + $args->{$key} = $CFG->{$key} unless (exists $args->{$key}); + } + +# Used for HTML editor + my %browser = $IN->browser_info; + delete $browser{is_ie} if $browser{is_ie} and $browser{ie_version} < 5.5; + @$args{keys %browser} = values %browser; + + $args->{html}->{in} = $IN; + $args->{html}->{sql} = $DB; + $args->{html}->{cfg} = $CFG; + $args->{selected_menu} = $MN_SELECTED; + +# Loads template globals + load_globals(); + +# Escapes HTML code + my $cgi = $IN->get_hash(); + my $content = $cgi->{msg_content_html}; + if ( $content ) { + $content =~ s,\r\n,\n,g; + $cgi->{msg_content_html} = $IN->html_escape($content); + } + + unless (defined $args->{hidden_query}) { + my $hidden = hidden(); + $args->{hidden_query} = $hidden->{hidden_query}; + $args->{hidden_objects} = $hidden->{hidden_objects}; + } + print $IN->header; + GT::Template->parse($template, [$args, $cgi, $GLOBALS, $USER || {}], { print => 1, root => $template_dir }); +} + +sub set_default_template { +#----------------------------------------------------------- +# Add default email template when adding a user +# + my ($fname, $userid) = @_; + require GT::Mail::Editor; + my $email = GT::Mail::Editor->new(dir => "$CFG->{priv_path}/templates", template => $CFG->{template_set}); + $email->load($fname); + my $hsh = {}; + my $cgi = $IN->get_hash(); + + $fname =~ s/\.eml//; + $hsh->{tpl_user_id_fk} = $userid; + $hsh->{tpl_name} = $fname; + $hsh->{tpl_to} = $email->{headers}->{To}; + $hsh->{tpl_from} = $email->{headers}->{From}; + $hsh->{tpl_subject}= $email->{headers}->{Subject}; + $hsh->{tpl_body} = $email->{body}; + + $DB->table('EmailTemplates')->insert($hsh); +} + +sub add { +#-------------------------------------------------------------------- +# Add a record +# + my ($table, $prefix, $cgi) = @_; + + my $db = $DB->table($table) or return $GT::SQL::error; + +# Turn arrays into delimited fields + $cgi ||= format_insert_cgi($db); + +# Save the current time + if ( $table eq 'Messages' ) { + $cgi->{msg_created} = time; + if ($cgi->{msg_content_html} =~ /^\s*\s*\s*<\/BODY>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*\s*<\/body>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*

\ <\/p><\/BODY>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*

\ <\/P><\/BODY>\s*<\/html>\s*$/mi) { + $cgi->{msg_content_html} = ""; + } + } + elsif ( $table eq 'Lists' ) { + $cgi->{lst_date_created} = time; + } + +# Add the record's owner + $cgi->{$prefix.'_user_id_fk'} = $USER->{usr_username}; + +# Setup the language for GT::SQL. + local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL') if ( language('ADD_ILLEGALVAL') ); + local $GT::SQL::ERRORS->{UNIQUE} = language('ADD_UNIQUE') if ( language('ADD_UNIQUE') ); + local $GT::SQL::ERRORS->{NOTNULL} = language('ADD_NOTNULL') if ( language('ADD_NOTNULL') ); + + my $cols = $db->cols; + + foreach my $c ( keys % $cols ) { + my $regex = $cols->{$c}->{form_regex}; + if ( $regex and $cgi->{$c} !~ /$regex/ ) { + $error .= language('SYS_REGEXFAIL', $cols->{$c}->{form_display}); + } + } + return if ( $error ); + if ( defined (my $ret = $db->add($cgi)) ) { + return $ret; + } + else { + local $^W; + $error = $GT::SQL::error; + } +} + +sub modify { +#-------------------------------------------------------------------- +# Modify a record +# + my ($table, $prefix, $cgi) = @_; + + my $db = $DB->table($table) or return $GT::SQL::error; + +# Format arrays for insertion + $cgi ||= format_insert_cgi($db, $cgi); + +# Check if users can modify only their own records except Administrator + if ( $USER->{usr_type} != ADMINISTRATOR ) { + my $lookup = {}; + my $pk = $db->pk; + foreach (@$pk) { $lookup->{$_} = $IN->param($_); } + my $rs = $db->get($lookup); + + if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) { + $error = language('SYS_PER_DENIED'); + return; + } + } + +# Setup the language for GT::SQL. + local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL') if ( language('ADD_ILLEGALVAL') ); + local $GT::SQL::ERRORS->{UNIQUE} = language('ADD_UNIQUE') if ( language('ADD_UNIQUE') ); + local $GT::SQL::ERRORS->{NOTNULL} = language('ADD_NOTNULL') if ( language('ADD_NOTNULL') ); + + if ( $table eq 'Messages' ) { + if ($cgi->{msg_content_html} =~ /^\s*\s*\s*<\/BODY>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*\s*<\/body>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*

\ <\/p><\/BODY>\s*<\/html>\s*$/mi or + $cgi->{msg_content_html} =~ /^\s*\s*

\ <\/P><\/BODY>\s*<\/html>\s*$/mi) { + $cgi->{msg_content_html} = ""; + } + if ($cgi->{msg_mode} eq 'text') { + $cgi->{msg_content_html} = ''; + } + } + if ( $db->modify($cgi) ) { + return; + } + else { + local $^W; + $error = $GT::SQL::error; + } +} + +sub delete { +#-------------------------------------------------------------------- +# Delete records +# + my ($table, $prefix, $cgi, $msg) = @_; + + my $db = $DB->table($table); + +# Create a cgi object + $cgi ||= $IN->get_hash(); + +# If they selected only one record to delete we still need an array ref + my $mod = ( ref $cgi->{modify} eq 'ARRAY' ) ? $cgi->{modify} : [$cgi->{modify}]; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$db->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + my $rec_declined = 0; + + + if ( $table eq 'Messages' or $table eq 'MailingIndex' ) { + require GT::File::Tools; + } + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num ( @{$mod} ) { + my $change = {}; + foreach my $column ( @columns ) { + $change->{$column} = $cgi->{"$rec_num-$column"} if ( $cgi->{"$rec_num-$column"} ); + } + +# Check for delete own record + if ( $USER->{usr_type} != ADMINISTRATOR ) { # As a user + my $rs = $db->get($change); + next if ( !$rs ); + if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) { + $rec_declined++; next; + } + } + next unless ( keys %$change ); + if ( $table eq 'MailingIndex' ) { + if ( int $cgi->{fd} and $cgi->{fd} == 3 ) { # Deletes records + my $info = $db->get($change) || {}; + if ( $USER->{usr_type} == ADMINISTRATOR or !$info->{mli_Done} ) { # Admin user + my $ret = $db->delete($change); + if ( defined $ret and ($ret != 0) ) { + $rec_modified++; + } + } + else { + $db->update({ mli_delete => '2', mli_cat_id_fk => 0, mli_root => '0' }, $change); + $rec_modified++; + } + } + else { # Marks records + $db->update({ mli_delete => '1', mli_cat_id_fk => 0, mli_root => '0' }, $change); + $rec_modified++; + } + } + else { + my $ret = $db->delete($change) or die $GT::SQL::error; + if ( defined $ret and ($ret != 0) ) { + $rec_modified++; + } + } + +# Remove attachments + my $id = $IN->param("$rec_num-msg_id"); + if ( $table eq 'Messages' and $id ) { + remove_attachments($id, 'messages'); + } + + $id = $IN->param("$rec_num-Mailing"); + if ( $table eq 'MailingIndex' and $id and $cgi->{fd} == 3 ) { + remove_attachments($id, 'mailings'); + } + } + $msg ||= ( $rec_declined ) ? GList::language('SYS_DELETED2', $rec_modified, $rec_declined) : GList::language('SYS_DELETED', $rec_modified); + return $msg; +} + +sub send { +#-------------------------------------------------------- +# Send a message by using GT::Mail +# + my ($head, $content, $attachments, $attach_path, $charset) = @_; + + $attachments ||= []; + $charset ||= 'us-ascii'; + require GT::Mail; + $GT::Mail::error ||= ''; # Silence -w + + my $m = GT::Mail->new(debug => $CFG->{debug_level}, header_charset => $charset); + my $parts; + if ( $content->{text} and $content->{html} ) { + $parts = $m->new_part('Content-Type' => "multipart/alternative; charset=\"$charset\""); + $parts->parts($m->new_part( + 'Content-Type' => "text/plain; charset=\"$charset\"", + body_data => $content->{text}, + encoding => 'quoted-printable' + )); + $parts->parts($m->new_part( + 'Content-Type' => "text/html; charset=\"$charset\"", + body_data => $content->{html}, + encoding => 'quoted-printable' + )); + } + elsif (@$attachments) { + my $msg = $content->{text} || $content->{html}; + my $type = ( $msg =~ m/(|)/i ? "text/html" : "text/plain" ); + $type = "text/html" if ($content->{html}); + $parts = $m->new_part( + 'Content-Type' => "$type; charset=\"$charset\"", + body_data => $msg, + encoding => 'quoted-printable' + ); + } + else { + my $msg = $content->{text} || $content->{html}; + my $type = ( $msg =~ m/(|)/i ? "text/html" : "text/plain" ); + $type = "text/html" if ($content->{html}); + $parts = $m->new_part( + 'Content-Type' => "$type; charset=\"$charset\"", + encoding => 'quoted-printable' + ); + $head->{body_data} = $msg; + } + +# Handle the attachments + if (@$attachments) { + my $apart = $m->new_part('Content-Type' => 'multipart/mixed'); + $apart->parts($parts); + for (@$attachments) { + my $id = $_->{att_id} || $_->{mat_id}; + my $filename = $_->{mat_file_name} || $_->{att_file_name}; + my $content_type = _load_mime("$attach_path/$id", $filename); + $apart->parts($m->new_part( + body_path => "$attach_path/$id", + encoding => '-guess', + filename => $filename, + 'Content-Type' => $content_type + )); + } + $parts = $apart; + } + + $head->{'Content-Type'} = $parts->get('Content-Type'); + + my $mail = GT::Mail->new( + %$head, + debug => $CFG->{debug_level}, + header_charset => $charset, + ); + for ($parts->parts()) { + $mail->attach($_); + } + + $mail->send( + smtp => $CFG->{smtp_server}, + sendmail => $CFG->{mail_path}, + ) or warn $GT::Mail::error; +} + +sub hidden { +#-------------------------------------------------------------------- +# + my $args = shift || []; + + push @$args, 'users'; + my $cgi = $IN->get_hash(); + my ($hidden_query, $hidden_objects) = ('', ''); + if ($CFG->{user_session} and ($cgi->{sid} or $USER->{session_id})) { + my $session_id = $cgi->{sid} || $USER->{session_id}; + $hidden_query = ";sid=$session_id"; + $hidden_objects = qq!!; + } + foreach (@$args) { + next unless $cgi->{$_}; + $hidden_query .= ";$_=$cgi->{$_};$_-opt=="; + $hidden_objects .= qq! + + !; + } + return { hidden_query => $hidden_query, hidden_objects => $hidden_objects }; +} + +sub _search_check { +#-------------------------------------------------------------------- +# + my ($cols, $cgi) = @_; + foreach (keys % $cols) { + my ($c) = $_ =~ /\.([^.]+)$/; + $c ||= $_; + if (exists $cgi->{$c} and $cgi->{$c}) { + return 1; + } + if ($cgi->{"$c-ge"} or $cgi->{"$c-le"} or $cgi->{"$c-gt"} or $cgi->{"$c-lt"}) { + return 1; + } + } + return; +} + +sub search { +#-------------------------------------------------------------------- +# Search engine +# + my $opts = ref $_[0] eq 'HASH' ? shift : { @_ }; + my $cgi = $opts->{cgi}; + my $db = $opts->{db}; + my $prefix = $opts->{prefix}; + my $based_on = $opts->{based_on}; + my $skip_user = $opts->{skip_user}; + my $search_check= $opts->{search_check}; + my $search_alpha= $opts->{search_alpha}; + my $search_col = $opts->{search_col}; + my $return_msg = $opts->{return_msg}; + my $select_all = $opts->{select_all}; + my $show_user = $opts->{show_user}; + my $int_field = $opts->{int_field}; + $return_msg ||= uc($prefix).'_RESULTS'; + + my $user_field = $prefix."_user_id_fk"; + my $nh = $cgi->{nh} || 1; + my $mh = $cgi->{mh} || 25; + my $ma = $cgi->{ma} || ''; + my $bg = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh; + my $sb = $cgi->{sb} || $opts->{sb}; + my $so = $cgi->{so} || $opts->{so}; + my $cols = $db->cols; + my $table_name = $db->name; + my $db_prefix = $DB->prefix; + $table_name =~ s/^$db_prefix//; + + $sb ||= $opts->{sb}; + $so ||= $opts->{so} || 'ASC'; + if ($search_check and !$cgi->{keyword} and !_search_check($cols, $cgi)) { + return { error => GList::language('SYS_SEARCH_ERROR') }; + } + +# Require GT's modules + require GT::SQL::Condition; + require GT::Date; + + my ($cd, @words); + my $query = ''; + if ( $cgi->{keyword} and $cgi->{keyword} ne '*' ) { # keyword search + $cd = new GT::SQL::Condition('OR'); + if ( $ma ) { # match any + @words = split(/\s/, $cgi->{keyword}); + } + else { + push @words, $cgi->{keyword}; + } + + foreach my $c ( keys % $cols ) { + if ( $cols->{$c}->{weight} ) { # search weight + foreach my $w ( @words ) { + $cd->add($c, 'like', "%$w%"); + } + } + } + $query = "keyword=$cgi->{keyword};"; + } + else { + my $bool = ( $ma ) ? 'OR' : 'AND'; + $cd = new GT::SQL::Condition($bool); + if ($search_alpha) { + if ( $search_col and $search_alpha eq 'other') { # for Subscribers table only + my $tmp = GT::SQL::Condition->new('OR'); + $tmp->add($search_col => '<' => '0'); + $tmp->add(GT::SQL::Condition->new($search_col => '>=' => ':', $search_col => '<' => 'a')); + $tmp->add($search_col => '>=' => '['); + $cd->add($tmp); + $query .= 'alpha=other;'; + } + elsif ( $search_col and $search_alpha eq 'number') { # for Subscribers table only + my $tmp = GT::SQL::Condition->new($search_col => '>=' => '0', $search_col => '<' => ':'); + $cd->add($tmp); + $query .= 'alpha=number;'; + } + else { + $cd->add($search_col, 'like', "$search_alpha%"); + } + } + + foreach my $c ( keys % $cols ) { + my $tc = $c; + if ( $based_on ) { + $tc =~ s/$based_on\.//; + } + next if ( $c and $cgi->{$tc} and ( $c eq $user_field or $cgi->{$tc} eq '*' )); + if ( $cols->{$c}->{type} =~ /date|datetime|timestamp/mi or !$cgi->{$tc} ) { # DATE fields + if ( defined $cgi->{$tc} and $cgi->{$tc} eq '0' ) { + $cd->add($c, $cgi->{"$tc-opt"} || '=', $cgi->{$tc} ); + $query .= "$tc=0;"; + } + else { + my $tmp = {'le' => '<=', 'ge' => '>=', 'lt' => '<', 'gt' => '>'}; + my $format = $USER->{usr_date_format} || '%mm%-%dd%-%yyyy%'; + foreach my $o (keys % {$tmp} ) { + next if ( !$cgi->{"$tc-$o"} ); + my $v; + if ($int_field) { + $v = $cgi->{"$tc-$o"}; + } + else { + $cgi->{"$tc-$o"} .= ( $o eq 'le' or $o eq 'lt' ) ? ' 23:59:58' : ' 00:00:01'; + $v = GT::Date::timelocal(GT::Date::parse_format($cgi->{"$tc-$o"}, "$format %hh%:%MM%:%ss%")); + } + $cd->add($c, $tmp->{$o}, $v); + $query .= "$tc-$o=".$cgi->{"$tc-$o"}.';'; + } + } + } + elsif ( $cgi->{"$tc-opt"} ) { + $cd->add($c, $cgi->{"$tc-opt"}, $cgi->{$tc}); + $query .= "$tc=$cgi->{$tc};$c-opt=".$cgi->{"$tc-opt"}.";"; + } + elsif ( $cols->{$c}->{type} =~ /char|varchar|text/mi ) { # TEXT fields + $cd->add($c, 'like', "%$cgi->{$tc}%"); + $query .= "$tc=$cgi->{$tc};"; + } + else { + $cd->add($c, '=', $cgi->{$tc}); + $query .= "$tc=$cgi->{$tc};"; + } + } + } + $query .= 'ma=1;' if ($ma); + my @extra = ('cs', 'mn_disable'); + foreach (@extra) { + $query .= "$_=$cgi->{$_};" if ($cgi->{$_}); + } + chop $query; + +# System users will view their own record only + my $cond = new GT::SQL::Condition($cd); + if ( !$skip_user ) { + if ( $USER->{usr_type} != ADMINISTRATOR ) { + $cond->add($user_field, '=', $USER->{usr_username}); + } + elsif ( $cgi->{$user_field} ) { + my $o = $cgi->{"$user_field-opt"} || '='; + $cond->add($user_field, $o, $cgi->{$user_field}); + } + else { + my $user = load_condition($show_user); + $cond->add($user_field, $user->{opt}, $user->{id}); + } + } +# Do the search and count the results. + if ( !$select_all ) { + $db->select_options("ORDER BY $sb $so LIMIT $bg, $mh "); + } + my $sth = $db->select($cond) or die $GT::SQL::error; + my $hits= $db->hits; + + return language($return_msg, 0) if ( $hits == 0 ); + + if ( $#words == -1 and $cgi->{lu} ) { + @words = split(/\s/, $cgi->{lu}); + } + my @output; + my @colors = ('#ff8888', '#88ff88', '#8888ff', '#ffff88', '#ff88ff', '#88ffff', '#ffcccc', '#cccc99', '#ffffcc', '#ffccff'); + while ( my $rs = $sth->fetchrow_hashref ) { + if ( $CFG->{highlight_color} ) { + if ( $#words != -1 ) { + foreach my $c ( keys % $cols ) { + next if ( !$cols->{$c}->{weight} ); + my $j = 0; + foreach my $i (0..$#words) { + $j = 0 if ( $j > $#colors ); + $rs->{$c} =~ s/$words[$i]/$words[$i]<\/span>/gi; + $j++; + } + } + } + } + push @output, $rs; + } + + return { hits => $hits, + results => \@output, + msg => language($return_msg, $hits), + query => $query, + mh => $mh, + nh => $nh, + lookup => $cgi->{keyword}, + toolbar_table => $table_name + }; +} + +sub remove_attachments { +#----------------------------------------------------------------------- +# + my ($id, $dir) = @_; + + my $path = "$CFG->{priv_path}/attachments/$dir/" . ($id % 10) . "/$id"; + (-e $path) or return "Invalid path $path!"; + + opendir (DIR, $path) or return GList::language('DIR_OPEN_ERR', $path, $!); + my @list = readdir(DIR); + closedir (DIR); + foreach my $file (@list) { + ($file eq '.') and next; + ($file eq '..') and next; + unlink "$path/$file"; + } + rmdir $path; + return; +} + +sub load_condition { +#----------------------------------------------------------------------- +# Loads the user listings in a group for searching +# It will be returned a hash +# + my $show_user = shift; + + my $cgi = $IN->get_hash(); + $show_user ||= $cgi->{users}; + if ( $show_user and $USER->{usr_type} == ADMINISTRATOR) { # For admin + return { id => $USER->{usr_username}, opt => '<>' }; + } + else { # Check current user + return { id => $USER->{usr_username}, opt => '=' }; + } +} + +sub get_data { +#-------------------------------------------------------------------- +# Get data of a record +# + my $table = shift; + + my $values; + my $mod = $IN->param('modify'); + + if ( $IN->param('modify') == 0 ) { + $values = $IN->get_hash; + } + else { + my $lookup = {}; + my $db = $DB->table($table); + my $pk = $db->pk; + foreach ( @$pk ) { $lookup->{$_} = $IN->param("$mod-$_"); } + $values = $db->get($lookup, 'HASH'); + } + + return $values; +} + +sub format_insert_cgi { +#----------------------------------------------------------------------------- +# + my ($db, $cgi) = @_; + + $cgi ||= $IN->get_hash; + my $cols = $db->cols; + foreach ( keys % $cols ) { + if ( !exists $cgi->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX' ) { + $cgi->{$_} = ''; + } + next unless ( ref ($cgi->{$_}) eq 'ARRAY' ); + $cgi->{$_} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort (@{$cgi->{$_}})); + } + return $cgi; +} + +sub check_owner { +#-------------------------------------------------------------------- +# User can only modify their own record, except admin +# + my ($table, $pre_fix, $id) = @_; + + my $info = $DB->table($table)->get($id); + ( $info ) or return "$id does not exist!"; + +# Users can only modify their own records + if ( $USER->{usr_type} != ADMINISTRATOR and $info->{$pre_fix.'_user_id_fk'} ne $USER->{usr_username} ) { + return GList::language('SYS_PER_DENIED'); + } + + return $info; +} + +sub check_limit { +#------------------------------------------------------------------------------ +# Check account limits +# + my ($type, $list_id) = @_; + return if ($USER->{usr_type} != LIMITED_USER); + + $error = ''; + if ($type eq 'list') { # limit number of list + if ($DB->table('Lists')->count({ lst_user_id_fk => $USER->{usr_username} }) >= $USER->{usr_limit_list}) { + $error = GList::language('SYS_OVERLIMIT_LIST'); + return 1; + } + } + elsif ($type eq 'sublist') { # limit number of subscribers per list + if ($DB->table('Subscribers')->count( + { sub_user_id_fk => $USER->{usr_username}, sub_list_id_fk => $list_id }) >= $USER->{usr_limit_sublist} ) { + $error = GList::language('SYS_OVERLIMIT_SUBLIST'); + return 1; + } + } + elsif ($type eq 'email30') { # limit number of email sending out in the last 30 days + require GT::Date; + require GT::SQL::Condition; + my $last30 = GT::Date::date_sub(GT::Date::date_get(), 30); + my $unix_time = date_to_time($last30); + my $num_sent = $DB->table('MailingIndex', 'EmailMailings')->count( + GT::SQL::Condition->new( + mli_user_id_fk => '=' => $USER->{usr_username}, + eml_sent => '>=' => $unix_time + ) + ); + if ( $num_sent >= $USER->{usr_limit_email30} ) { + $error = GList::language('SYS_OVERLIMIT_EMAIL30'); + return 1; + } + return $num_sent; + } + return; +} + +sub load_language { +# ----------------------------------------------------------------------------- +# Loads the language.txt file. You can either pass in a template set, or let +# it auto-detect from t=, or fall back to the default. +# + my $t = shift || scalar $IN->param('t') || $CFG->{template_set} || 'gossamer'; + $LANGUAGE = undef if !$LANG_TPL or $LANG_TPL ne $t; + $LANGUAGE ||= GT::Config->load("$CFG->{priv_path}/templates/$t/language.txt", { create_ok => 1, inheritance => 1, local => 1, header => <

load("$CFG->{priv_path}/templates/common/globals.txt", { + $no_subs ? () : (compile_subs => 'GList'), + inheritance => 1, + local => 1, + cache => 1, + header => <<'HEADER' +# This file is auto generated and contains a perl hash of +# your template globals. +# Generated on: [localtime] + +HEADER + }); + $GLOB_NO_SUBS = $no_subs; +} + +sub language { +# ------------------------------------------------------------------ +# Process a language request, it's only loaded once, and saved in +# $LANGUAGE. +# + require GT::Config; + my $code = shift || ''; + + load_language(); + + if (exists $LANGUAGE->{$code}) { + return @_ ? sprintf($LANGUAGE->{$code}, @_) : $LANGUAGE->{$code}; + } + else { + return $code; + } +} + +sub fatal { +# -------------------------------------------------------------- +# Return a fatal error message to the browser. +# + die @_ if (GT::Base->in_eval()); # Don't do anything if we are in eval. + + my $msg = shift; + my $debug = defined $CFG->{debug_level} ? $CFG->{debug_level} : $DEBUG; + + $IN ||= new GT::CGI; + if (defined $CFG and exists $CFG->{error_message} and $CFG->{error_message}) { + $CFG->{error_message} =~ s,<%error%>,$msg,g; + $CFG->{error_message} =~ s,<%environment%>,environment(),eg; + display('error_form.html', { msg => language('SYS_FATAL', $CFG->{error_message}) }); + } + else { + display('error_form.html', { msg => language('SYS_FATAL', $msg) }); + } + if ($debug) { + print environment(); + } +} + +sub view_file { +#--------------------------------------------------------------- +# View a file +# + my $fn = $IN->param('fn'); + my $fd = $IN->param('fd'); + my $type = $IN->param('ft'); + $fn and $fd or return display('error_form.html', { msg => language('SYS_FILE_INVALID') }); + +# Check file existing + my $file = $DB->table($type ? 'MessageAttachments' : 'MailingAttachments')->get($fn); + $file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) }); + + my $full_file = "$CFG->{priv_path}/attachments/".(( $type ) ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn"; + my $file_name = ( $type ) ? 'att_file_name' : 'mat_file_name'; + my $content_type = _load_mime($file->{$file_name}); + my ($ext) = $full_file =~ /\.([^.]+)$/; + my $file_size = -s $full_file; + if (open DATA, $full_file) { + if (($content_type =~ m/text/ or -T $full_file) and uc($ext) ne 'PDF') { + print $IN->header; + } + else { + warn "Content-type: $content_type, Content-Length: $file_size"; + print $IN->header({ + '-type' => $content_type, + '-Content-Length' => $file_size, + }); + } + binmode STDOUT; + binmode DATA; + my $buffer; + print $buffer while (read(DATA, $buffer, READ_SIZE)); + close DATA; + return; + } + else { + return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) }); + } +} + +sub download_file { +#-------------------------------------------------------------- +# Download a file +# + my $fn = $IN->param('fn'); + my $fd = $IN->param('fd'); + my $type = $IN->param('ft'); + ( $fn and $fd ) or return display('error_form.html', { msg => language('SYS_FILE_INVALID') }); + +# Check file existing + my $file = $DB->table(( $type ) ? 'MessageAttachments' : 'MailingAttachments')->get($fn); + $file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) }); + + my $full_file = "$CFG->{priv_path}/attachments/".($type ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn"; + my $file_name = $type ? 'att_File_Name' : 'mat_File_Name'; + my $file_size = -s $full_file; + if (open DATA, $full_file) { + print $IN->header( + '-type' => 'application/download', + '-Content-Length' => $file_size, + '-Content-Transfer-Encoding' => 'binary', + '-Content-Disposition' => \"attachment; filename=$file->{$file_name}" + ); + binmode STDOUT; + binmode DATA; + my $buffer; + print $buffer while (read(DATA, $buffer, READ_SIZE)); + close DATA; + return; + } + else { + return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) } ); + } +} + +sub encrypt { +# ------------------------------------------------------------------- + my ($clear_pass, $salt) = @_; + defined $salt or ($salt = ''); + require GT::MD5::Crypt; + if (! $salt) { + my @rand_salt = ('a' .. 'z', 'A' .. 'Z', 0 .. 9, '.', '/'); + for (1 .. 8) { $salt .= $rand_salt[rand @rand_salt]; } + } + my $enc_pass = GT::MD5::Crypt::gt_md5_crypt($clear_pass, $salt); + return $enc_pass; +} + +sub date_to_time { + my ($date, $date_format) = @_; + my $lt; + my @localtime; + require GT::Date; + + $date_format ||= '%yyyy%-%mm%-%dd%'; + DATE: { + # First, try the admin format: + ref($lt = GT::Date::_parse_format($date, $date_format)) eq 'ARRAY' and (@localtime = @$lt), last DATE; + # Okay, it wasn't simply them modifying what was displayed, so let's try some other common formats: + # just the date, no time: + # yyyy/mm/dd + $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d%")}), last DATE; + # 12 hour time: + # yyyy/mm/dd hh:MM [AP]M + $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M% %tt%")}), last DATE; + # yyyy/mm/dd hh:MM:ss [AP]M + $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M%:%s% %tt%")}), last DATE; + # 24 hour time: + # yyyy/mm/dd HH:MM + $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%")}), last DATE; + # yyyy/mm/dd HH:MM:ss + $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%:%s%")}), last DATE; + # Common formats that can't be recognized: + # dd/mm/yyyy - These two are conflicting US/European formats and it would + # mm/dd/yyyy - be impossible to figure out which one you are trying to use. + } + + return scalar @localtime ? GT::Date::timelocal(@localtime) : undef; +} + +sub paging { +# -------------------------------------------------------------- +# Returns paging variables for the templates. +# Takes 4 arguments: number of hits, hits per page, the current page, and the number of pages to show. +# Takes 1 additional optional argument - true or false, indicating whether or not a ... system will be +# used. If set, one extra number will be returned if there is just one extra number needed, and a +# 'dotdotdot' variable will be available as 1 if ... is needed. +# Example: when displaying paging of 9 with 11 pages, you would get: +# 1 2 3 4 5 6 7 8 9 and you would have the "dotdotdot" variable set, so you would put a ... and then 11. +# Now, if you were displaying paging of 9 with 10 pages, you would actually get _10_ numbers: +# 1 2 3 4 5 6 7 8 9 10 and the "dotdotdot" wouldn't be set, so you wouldn't put the ... 10, since +# 1 2 3 4 5 6 7 8 9 ... 10 would look silly. +# Returned is a hashref: { paging => LOOP, top_page => INTEGER }, and possibly dotdotdot => 1 +# Inside the loop you have: <%page_num%> and <%is_current_page%>. +# + my ($num_hits, $max_hits, $current_page, $disp_pages, $want_dotdotdot) = @_; + + $disp_pages ||= 20; + $max_hits ||= 25; + my $num_pages = int($num_hits / $max_hits); + $num_pages++ if $num_hits % $max_hits; + my ($start, $end); + if ($num_pages <= $disp_pages) { + $start = 1; + $end = $num_pages; + } + elsif ($current_page >= $num_pages - $disp_pages / 2) { + $end = $num_pages; + $start = $end - $disp_pages + 1; + } + elsif ($current_page <= $disp_pages / 2) { + $start = 1; + $end = $disp_pages; + } + else { + $start = $current_page - int($disp_pages / 2) + 1; + $start-- if $disp_pages % 2; + $end = $current_page + int($disp_pages / 2); + } + my $need_dotdotdot; + if ($want_dotdotdot) { + if ($num_pages == $end + 1) { + ++$end; + } + elsif ($num_pages > $end) { + $need_dotdotdot = 1; + } + } + my @pages = map +{ page_num => $_, (($_ == $current_page) ? (is_current_page => 1) : ()) }, $start .. $end; + return { + paging => \@pages, + top_page => $num_pages, + ($want_dotdotdot && $need_dotdotdot ? (dotdotdot => 1) : ()) + }; +} +sub wild_cards() { + require GT::SQL::Condition; + return $DB->table('StopLists')->select(GT::SQL::Condition->new(stl_email => LIKE => "%*%", stl_email => LIKE => "%?%", "OR"), ['stl_email'])->fetchall_arrayref; +} + +sub _redirect_login_url { +# -------------------------------------------------------------- +# Redirect the user to the login screen. +# + my $url = $IN->url( query_string => 1 ); + $url = $CFG->{cgi_url} . "/user.cgi?url=" . $IN->escape($url); + foreach my $preserve (@{$CFG->{dynamic_preserve}}) { + my $val = $IN->param($preserve); + defined $val or next; + $url .= ";$preserve=" . $IN->escape($val); + } + return $url; +} + +sub _load_mime { +# -------------------------------------------------------------------- +# Load the config file into a hash. +# + my ($file, $name) = @_; + $name ||= $file; + require GT::MIMETypes; + my $guess = GT::MIMETypes->guess_type($name); + if (!$guess or $guess eq 'application/octet-stream') { + if (-e $file) { + $guess = -T _ ? 'text/plain' : 'application/octet-stream'; + } + else { + $guess = 'application/octet-stream'; + } + } + return $guess; +} + +sub _load_global { + my $name = shift; + load_globals(); + return if (!exists $GLOBALS->{$name}); + + my $value = $GLOBALS->{$name}; + $value = $value->() if ref $value eq 'CODE'; + return $value; +} + +1; diff --git a/site/glist/lib/GList/Admin.pm b/site/glist/lib/GList/Admin.pm new file mode 100644 index 0000000..1b2e94a --- /dev/null +++ b/site/glist/lib/GList/Admin.pm @@ -0,0 +1,1344 @@ +# ================================================================== +# Gossamer List - enhanced mailing list management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : +# Revision : $Id: Admin.pm,v 1.59 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::Admin; + +use strict; +use GList qw/:user_type :objects $DEBUG/; +use GT::AutoLoader; + +sub process { +#------------------------------------------------------------------ +# Setermine what to do +# + my $do = shift; + + my $action = _determine_action($do) or die "Error: Invalid Action! ($do)"; + if ($action eq 'admin_gtdoc') { + return GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action); + } + + my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action); + if ($tpl) { + $MN_SELECTED = 6 if ($tpl =~ /^admin_user/); + my $hidden = GList::hidden(); + $results->{hidden_query} = $hidden->{hidden_query}; + $results->{hidden_objects} = $hidden->{hidden_objects}; + GList::display($tpl, $results); + } +} + +$COMPILE{admin_gtdoc} = <<'END_OF_SUB'; +sub admin_gtdoc { +#------------------------------------------------------------------- +# + my $template = $IN->param('topic') || 'index.html'; + + my $help_path = "$CFG->{priv_path}/templates/help"; + $template =~ s,^/|/$,,; + +# Check the topic file. + unless ( $template =~ /^[\w\/]+\.[\w]+$/ ) { + die "Invalid topic: $template"; + } + if ( $template =~ /\.(gif|jpg)$/ and -e "$help_path/$template" ) { + print $IN->header("image/$1"); + open IMG, "< $help_path/$template" or die "Unable to open image help: $help_path/$template ($!)"; + binmode IMG; + local *BINSTDOUT; + open BINSTDOUT, ">&STDOUT"; + binmode BINSTDOUT; + print BINSTDOUT while ; + close IMG; + } + else { + print $IN->header; + GT::Template->parse ($template, $USER, { print => 1, root => $help_path }); + } +} +END_OF_SUB + +$COMPILE{admin_page} = <<'END_OF_SUB'; +sub admin_page { +#-------------------------------------------------------------------- +# + my ($page, $vars) = @_; + + $page ||= $IN->param('pg'); + ( $page ) or return admin_user(GList::language('ADM_INVALID')); + + if ( $page =~ /^admin_template_/ ) { + $MN_SELECTED = 7; + } + elsif ( $page =~ /plugin_|gt_doc/ ) { + $MN_SELECTED = 8; + } + elsif ( $page =~ /admin_setup_/ ) { + $MN_SELECTED = 9; + } + + return ($page, $vars); +} +END_OF_SUB + +$COMPILE{admin_initial_sql} = <<'END_OF_SUB'; +sub admin_initial_sql { +#------------------------------------------------------------------- +# + my $sql = _sql_load_cfg(); + unless ( $IN->param('setup_sql') ) { + return ('admin_initial_sql.html', { %$sql, msg => GList::language("ADM_CONNECTION_ERROR") }); + } + my $do = $IN->param('action'); + if ($do !~ /^create|overwrite|load$/) { + return ('admin_initial_sql.html', { msg => "Invalid action: '$do'", $sql }); + } + + my $ret = _sql_connect($IN->param('sql_host'), $IN->param('sql_driver'), $IN->param('sql_database'), $IN->param('sql_login'), $IN->param('sql_password'), $IN->param('sql_prefix')); + if (exists $ret->{error}) { + return ('admin_initial_sql.html', { msg => $ret->{error}, $sql }); + } + + my $output; + if ($do eq 'create') { + $output = GList::SQL::tables('check'); + } + elsif ($do eq 'overwrite') { + $output = GList::SQL::tables('force'); + } + elsif ($do eq 'load') { + $output = GList::SQL::load_from_sql(); + } + + if ( !$DB->table('Users')->count({ usr_Username => $USER->{username}}) ) { + my $user = $CFG->{admin}->{$USER->{username}}; + my %hash; + $hash{usr_type} = ADMINISTRATOR; + $hash{usr_username} = $USER->{username}; + $hash{usr_password} = $user->[0]; + $hash{usr_email} = $user->[1]; + $hash{pro_first_name} = $USER->{username}; + $hash{pro_last_name} = $USER->{username}; + $hash{usr_date_format} = '%yyyy%-%mm%-%dd%'; + $DB->table('Users')->insert(%hash) or die $GT::SQL::error; + } + + my $results = GList::Authenticate::auth('create_session', { username => $USER->{username} }); + ( $results->{error} ) and return ('login_form.html', { msg => "$results->{error}" }); + +# Delete session file if it has being used + GList::Authenticate::auth('admin_delete_session'); + +# Administrator users need to be saved in Data.pm + _save_users(); + + return ('admin_initial_sql_results.html', { msg => $output }); +} +END_OF_SUB + +$COMPILE{admin_initial_setup} = <<'END_OF_SUB'; +sub admin_initial_setup { +# ------------------------------------------------------------------ +# Sets the mysql information. +# + my ($host, $port, $overwrite); + + unless ( $IN->param('initial_step') ) { + return admin_page('admin_initial_setup_first.html'); + } + if ( $IN->param('initial_step') == 2 ) { + return admin_page('admin_initial_setup_second.html'); + } + +# Test the ability to create a def file. + unless (open (TEST, "> $CFG->{priv_path}/defs/database.def")) { + return ('admin_initial_setup_second.html', { error => sprintf(GList::language('ADM_INITIAL_ERROR'), "$CFG->{priv_path}/defs/", $!) }); + } + close TEST; + unlink "$CFG->{priv_path}/defs/database.def"; + +# Set the connection info. + $overwrite = $IN->param('overwrite') ? 'force' : 'check'; + $host = $IN->param('host'); + ($host =~ s/\:(\d+)$//) and ($port = $1); + + my $prefix = $IN->param('prefix'); + $prefix =~ /^\w*$/ or return ('admin_initial_setup_second.html', { error => sprintf(GList::language('ADM_INITIAL_PREFIX_ERROR'), $prefix) }); + + $DB->prefix($prefix); + my $ret = $DB->set_connect ({ + driver => scalar $IN->param('driver'), + host => $host, + port => $port, + database => scalar $IN->param('database'), + login => scalar $IN->param('login'), + password => scalar $IN->param('password'), + RaiseError => 0, + PrintError => 0, + AutoCommit => 1 + }); + if (! defined $ret) { + return ('admin_initial_setup_second.html', { error => $GT::SQL::error }); + } +# Now let's create the tables. + eval { local $SIG{__DIE__}; require GList::SQL; }; + if ($@) { return ('admin_initial_setup_second.html', { error => sprintf(GList::language('ADM_INITIAL_LOAD_ERROR'), "$@\n") }); } + my $output = GList::SQL::tables($overwrite); + +# Remove admin users and Add an admin user + + my $user; + foreach (keys % {$CFG->{admin}}) { + $user = $_;last; + } + if ($user) { + my $db = $DB->table('Users'); + $db->delete({ usr_type => ADMINISTRATOR }); + if ( !$db->insert({ + usr_username => $user, + usr_email => $CFG->{admin}->{$user}->[1], + usr_password => $CFG->{admin}->{$user}->[0], + usr_type => ADMINISTRATOR, + usr_reply_email => $CFG->{admin}->{$user}->[1], + usr_bounce_email => $CFG->{admin}->{$user}->[1], + usr_date_format => '%yyyy%-%mm%-%dd%', + pro_first_name => $user, + pro_last_name => $user, + }) ) { + return ('admin_initial_setup_second.html', { error => $GT::SQL::error }); + } + } + +# Set default email templates + GList::set_default_template('validation.eml', $IN->param('admin_user')); + GList::set_default_template('subscribe.eml', $IN->param('admin_user')); + GList::set_default_template('unsubscribe.eml', $IN->param('admin_user')); + +# And lets set sensible defaults for the rest of the config vars. + $CFG->create_defaults(); + +# And save the config. + $CFG->save(); + + return ('admin_initial_setup_third.html', { message => sprintf(GList::language('ADM_INITIAL_SUCCESSFUL'), $output) } ); +} +END_OF_SUB + +$COMPILE{admin_user} = <<'END_OF_SUB'; +sub admin_user { +#-------------------------------------------------------------------- +# Print home page +# + my $msg = shift; + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $cgi = $IN->get_hash; + my $search_check = ($IN->param('do') eq 'admin_user_search') ? 1 : 0; + my $results = GList::search( + cgi => $cgi, + db => $DB->table('Users'), + prefix => 'usr', + sb => 'usr_type', + so => 'ASC', + skip_user => '1', + search_check=> $search_check + ); + + if ( ref $results ne 'HASH' ) { + ( $IN->param('do') eq 'admin_user_search' ) ? return ('admin_user_search_form.html', { msg => $results }) + : return ('admin_user_home.html', { msg => $results }); + } + elsif ( $results->{error} and $search_check) { + return ('admin_user_search_form.html', { msg => $results->{error} }) + } + + my $output = $results->{results}; + $results->{msg} = ($msg) ? $msg : GList::language('USR_RESULTS', $results->{hits}); + + return ('admin_user_home.html', $results); +} +END_OF_SUB + +$COMPILE{admin_user_add} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_add { +#-------------------------------------------------------------------- +# Add a user +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $cols = $DB->table('Users')->cols; + my $cgi = {}; + + foreach ( keys % $cols) { + $cgi->{$_} = $IN->param("mod_$_") if ( $IN->param("mod_$_") ); + } + + ($cgi->{usr_username} and $cgi->{usr_username} =~ /^[\w\-\.]{3,}$/) or return ('admin_user_add_form.html', { msg => GList::language('USR_INVALID') }); + ($cgi->{usr_password} and length $cgi->{usr_password} < 4 ) and return ('admin_user_add_form.html', { msg => GList::language('ADM_PWD_INVALID') }); + + $cgi->{usr_password} = GList::encrypt($cgi->{usr_password}); + $cgi->{usr_date_format} = $IN->param('date_preview') if ($IN->param('date_preview')); + $cgi->{usr_date_format}||= "%yyyy%-%mm%-%dd%"; + +# Set account limits + $cgi = _account_limit($cgi); + +# Add a new record + GList::add('Users', 'usr', $cgi); + + return ('admin_user_add_form.html', { msg => sprintf(GList::language('USR_ADD_ERR', $GList::error)) }) if ( $GList::error ); + +# Add user info into Data.pm if user is a administrator + if ( $cgi->{usr_type} == ADMINISTRATOR and not exists $CFG->{admin}->{$cgi->{usr_username}}) { + $CFG->{admin}->{$cgi->{usr_username}} = [$cgi->{usr_password}, $cgi->{usr_email}]; + $CFG->save(); + } + +# Set default email templates + GList::set_default_template('validation.eml', $cgi->{usr_username}); + GList::set_default_template('subscribe.eml', $cgi->{usr_username}); + GList::set_default_template('unsubscribe.eml', $cgi->{usr_username}); + + admin_user(sprintf(GList::language('USR_ADDED'), $cgi->{usr_username})); +} +END_OF_SUB + +$COMPILE{admin_user_modify_form} = <<'END_OF_SUB'; +sub admin_user_modify_form { +#----------------------------------------------------------- +# Print modify a user form +# + my $msg = shift; + + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $id = $IN->param('uid'); + my $db = $DB->table('Users'); + my $user = $db->get($id); + ( $user ) or return admin_user(sprintf(GList::language('USR_NOT_FOUND'), $id)); + + my $cols = $db->cols; + my $hsh = {}; + foreach ( keys % $cols ) { + $hsh->{"mod_$_"} = $user->{$_}; + } + return ('admin_user_modify_form.html', { msg => $msg, modify => 1, %$hsh }); +} +END_OF_SUB + +$COMPILE{admin_user_modify} = <<'END_OF_SUB'; +sub admin_user_modify { +#----------------------------------------------------------- +# Modify a user +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $db = $DB->table('Users'); + my $cols = $db->cols; + my $hsh = {}; + my $cgi = $IN->get_hash(); + + foreach ( keys % $cols) { + next if ( $USER->{usr_username} eq $cgi->{mod_usr_username} and $_ eq 'usr_type' ); + $hsh->{$_} = $cgi->{"mod_$_"} if (exists $cgi->{"mod_$_"}); + } + +# Setup the language for GT::SQL. + local $GT::SQL::ERRORS->{ILLEGALVAL} = GList::language('USR_ILLEGALVAL') if ( GList::language('USR_ILLEGALVAL') ); + local $GT::SQL::ERRORS->{UNIQUE} = GList::language('USR_UNIQUE') if ( GList::language('USR_UNIQUE') ); + local $GT::SQL::ERRORS->{NOTNULL} = GList::language('USR__NOTNULL') if ( GList::language('USR__NOTNULL') ); + + $hsh->{usr_cookie} = 0 if ( !defined $hsh->{usr_cookie} ); + if ($hsh->{usr_type} == ADMINISTRATOR or $hsh->{usr_type} == UNLIMITED_USER) { + $hsh->{usr_validate_code} = ''; + } + + if ($hsh->{usr_password}) { + $hsh->{usr_password} = GList::encrypt($hsh->{usr_password}); + } + else { + delete $hsh->{usr_password}; + } + + $hsh->{usr_date_format} = $IN->param('date_preview') if ($IN->param('date_preview')); + $hsh->{usr_date_format}||= "%yyyy%-%mm%-%dd%"; + my $old = $db->get($hsh->{usr_username}); + +# Set account limits + $hsh = _account_limit($hsh); + +# Email validate this account + if ($CFG->{signup_admin_validate} and $cgi->{email_validate}) { + $hsh->{usr_validate_code} = ''; + } + + if ( $db->modify($hsh) ) { + my $pass = $hsh->{usr_password} || $old->{usr_password}; + if ( $old->{usr_type} ne $hsh->{usr_type} ) { # Update Data.pm + if ( $hsh->{usr_type} == ADMINISTRATOR ) { + exists $CFG->{admin}->{$hsh->{usr_username}} or $CFG->{admin}->{$hsh->{usr_username}} = [$pass, $hsh->{usr_email}]; + } + else { + exists $CFG->{admin}->{$hsh->{usr_username}} and delete $CFG->{admin}->{$hsh->{usr_username}}; + } + $CFG->save(); + } + elsif ($hsh->{usr_type}) { + $CFG->{admin}->{$hsh->{usr_username}} = [$pass, $hsh->{usr_email}]; + $CFG->save(); + } + return admin_user(sprintf(GList::language('USR_UPDATED'), $hsh->{usr_username})); + } + else { + local $^W; + return admin_user_modify_form("$GT::SQL::error"); + } +} +END_OF_SUB + +$COMPILE{admin_user_delete} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_delete { +#------------------------------------------------------------------- +# Delete the glist users +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $cgi = $IN->get_hash(); + my $dels = (ref $cgi->{modify} eq 'ARRAY') ? $cgi->{modify} : [$cgi->{modify}]; + my (%hsh, @mods, @users); + foreach (@$dels) { + next if ($cgi->{"$_-usr_username"} eq $USER->{usr_username}); + $hsh{"$_-usr_username"} = $cgi->{"$_-usr_username"}; + push @mods, $_; + push @users, $cgi->{"$_-usr_username"}; + } + $hsh{modify} = \@mods; + + my $msg = GList::delete('Users', 'usr', \%hsh); + +# Delete users from Data.pm if they are administrator users + foreach my $u (@users) { + next if (not exists $CFG->{admin}->{$u}); + delete $CFG->{admin}->{$u}; + $CFG->save(); + } + return admin_user($msg); +} +END_OF_SUB + +$COMPILE{admin_user_validate} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_validate { +#------------------------------------------------------- +# Validate users +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $cgi = $IN->get_hash(); + my $mod = (ref $cgi->{modify} eq 'ARRAY') ? $cgi->{modify} : [$cgi->{modify}]; + + my $db_usr = $DB->table('Users'); + my $count = 0; + foreach (@$mod) { + my $u = $cgi->{"$_-usr_username"}; + next if (!$u or $u eq $USER->{usr_username}); + if ($db_usr->count({ usr_username => $u })) { + $db_usr->update({ + usr_type => LIMITED_USER, + usr_validate_code => '', + usr_limit_list => $CFG->{signup_limit_list} || 10, + usr_limit_sublist => $CFG->{signup_limit_sublist} || 10, + usr_limit_email30 => $CFG->{signup_limit_email30} || 100, + }, { usr_username => $u }); + $count++; + } + } + return admin_user(GList::language('USR_VALIDATED', $count)); +} +END_OF_SUB + +$COMPILE{admin_plugin} = <<'END_OF_SUB'; +sub admin_plugin { +# ------------------------------------------------------------------ +# Run a plugin function. +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $plugin = $IN->param('plugin'); + my $func = $IN->param('func'); + { + local ($@, $!, $SIG{__DIE__}); + eval { require "$CFG->{priv_path}/lib/GList/Plugins/$plugin.pm"; }; + if ( $@ ) { + return ('error_form.html', { msg => "Unable to load plugin: $plugin ($@)" }); + } + } + no strict 'refs'; + my $code = ${"GList::Plugins::" . $plugin . "::"}{$func}; + use strict 'refs'; + + if ( !defined $code ) { + return ('error_form.html', { msg => "Invalid plugin function: $func" }); + } + $code->(); +} +END_OF_SUB + + +$COMPILE{admin_setup_sql_form} = <<'END_OF_SUB'; +sub admin_setup_sql_form { +# ------------------------------------------------------------------ +# Print SQL Server Form +# + my $msg = shift; + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $sql = _sql_load_cfg(); + return ('admin_setup_sql_form.html', { msg => $msg, %$sql }); +} +END_OF_SUB + +$COMPILE{admin_setup_sql} = <<'END_OF_SUB'; +sub admin_setup_sql { +# ------------------------------------------------------------------ +# Change the sql server information. +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my ($host, $port, $output, $do, $ret); + + $do = $IN->param('action'); + if ($do !~ /^create|overwrite|load$/) { + return admin_setup_sql_form("Invalid action: '$do'"); + } + + $ret = _sql_connect($IN->param('sql_host'), $IN->param('sql_driver'), $IN->param('sql_database'), $IN->param('sql_login'), $IN->param('sql_password'), $IN->param('sql_prefix')); + if (exists $ret->{error}) { + return admin_setup_sql_form($ret->{error}); + } + + require GList::SQL; + if ($do eq 'create') { + $output = GList::SQL::tables('check'); + } + elsif ($do eq 'overwrite') { + $output = GList::SQL::tables('force'); + my $db = $DB->table('Users'); + $db->insert($USER) or die $GT::SQL::error; + + my $results = GList::Authenticate::auth('create_session', { username => $USER->{usr_username} }); + ( $results->{error} ) and return ('login_form.html', { msg => "$results->{error}" }); + +# Save username and password into Data.pm + $CFG->{admin} = { $USER->{usr_username} => [$USER->{usr_password}, $USER->{usr_email}] }; + $CFG->save(); + } + elsif ($do eq 'load') { + $output = GList::SQL::load_from_sql(); + } + + return admin_setup_sql_form("$output", 'is_set'); +} +END_OF_SUB + +$COMPILE{admin_setup_form} = <<'END_OF_SUB'; +sub admin_setup_form { +# ------------------------------------------------------------------ +# Print Setup form +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $msg = shift; + require GList::Config; + my $cfg = GList::Config::tpl_load(); + my $pg = $IN->param('pg') || 'admin_setup_path.html'; + + return ($pg, { %$cfg, msg => $msg }); +} +END_OF_SUB + +$COMPILE{admin_setup} = <<'END_OF_SUB'; +sub admin_setup { +# ------------------------------------------------------------------ +# Set the configuration. +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $cgi = $IN->get_hash(); + + if ( $cgi->{pg} eq 'admin_setup_misc.html' and (($cgi->{mail_path} and $cgi->{smtp_server}) or (!$cgi->{smtp_server} and !$cgi->{mail_path})) ) { + return admin_setup_form(GList::language('SET_MISC_ERR')); + } + + if ( !$cgi->{brestore} and exists $cgi->{cgi_url} and exists $cgi->{priv_path} and exists $cgi->{image_url} and + ( !$cgi->{cgi_url} or !$cgi->{priv_path} or !$cgi->{image_url} ) ) { + return admin_setup_form(GList::language('SET_PATH_ERR')); + } + + if ($cgi->{brestore}) { + $CFG->default_path (1); + } + else { + _update_cfg(); + } + $CFG->save(); + return admin_setup_form(GList::language('SET_CFG_SUCCESS')); +} +END_OF_SUB + +$COMPILE{admin_template_diff} = <<'END_OF_SUB'; +sub admin_template_diff { +# ------------------------------------------------------------------ +# Load fileman, but just for the purposes of displaying a diff. +# + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + require GT::FileMan; + my $fileman = GT::FileMan->new( + cfg => { + template_root => "$CFG->{priv_path}/templates/common", + root_dir => "$CFG->{priv_path}/templates", + html_root_url => $CFG->{image_url}. '/fileman', + debug_level => 0, + winnt => $^O eq 'MSWin32' ? 1 : 0, + command_time_out => 20, + allowed_space => 0, + }, + url_opts => 'do=fileman_diff' + ); + $fileman->process();exit; +} +END_OF_SUB + +$COMPILE{init_setup} = __LINE__ . <<'END_OF_SUB'; +sub init_setup { +# ------------------------------------------------------------------ +# Sets the mysql information. +# + my ($host, $port, $overwrite); +# Test the ability to create a def file. + + unless (open (TEST, "> $CFG->{priv_path}/defs/database.def")) { + return GList::display('setup_second.html', { + error => "Unable to create our def file in $CFG->{priv_path}/defs/.
\n + Please make sure this directory exists, and is writeable by the server.
\n + If this is the wrong directory, you will need to manually set the directory
\n + in GList::ConfigData. Error was: $!" + }); + } + close TEST; + unlink "$CFG->{priv_path}/defs/database.def"; + +# Set the connection info. + $overwrite = $IN->param('overwrite') ? 'force' : 'check'; + $host = $IN->param('host'); + ($host =~ s/\:(\d+)$//) and ($port = $1); + + my $prefix = $IN->param('prefix'); + $prefix =~ /^\w*$/ or return GList::display('setup_second.html', { error => "Invalid prefix: '$prefix'. Can only be letters, numbers and underscore." }); + + $DB->prefix($prefix); + my $ret = $DB->set_connect ({ + driver => scalar $IN->param('driver'), + host => $host, + port => $port, + database => scalar $IN->param('database'), + login => scalar $IN->param('login'), + password => scalar $IN->param('password'), + RaiseError => 0, + PrintError => 0, + AutoCommit => 1 + }); + if (! defined $ret) { + return GList::display('setup_second.html', { error => $GT::SQL::error }); + } +# Now let's create the tables. + eval { local $SIG{__DIE__}; require GList::SQL; }; + if ($@) { return GList::display('setup_second.html', { error => "Unable to load Dbsql::SQL module: $@\n" }); } + + my $output = GList::SQL::tables($overwrite); + +# Add admin user + my $db = $DB->table('Users'); + $db->insert({ + usr_email => $IN->param('admin_user'), + usr_password => $IN->param('admin_pass'), + usr_type => ADMINISTRATOR, + usr_reply_email => $IN->param('admin_user'), + usr_bounce_Email => $IN->param('admin_user') + }); + if ( $GT::SQL::error ) { + return GList::display('setup_second.html', { error => $GT::SQL::error }); + } + +# And lets set sensible defaults for the rest of the config vars. + $CFG->create_defaults(); + +# And save the config. + $CFG->save(); + + GList::display('setup_third.html', { message => "The data tables have been setup:
$output
" } ); +} +END_OF_SUB + +$COMPILE{admin_user_table} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_table { +#-------------------------------------------------------------------- +# Load Users table properties +# + my $msg = shift; + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $db_usr = $DB->table('Users'); + my $cols = $db_usr->cols; + my $pro_cols = [ grep(/^pro_/, $db_usr->ordered_columns) ]; + + my @output; + foreach my $c ( @$pro_cols ) { + $cols->{$c}->{name} = $c; + push @output, $cols->{$c}; + } + + return ('admin_user_table.html', { loop_fields => \@output, msg => $msg }); +} +END_OF_SUB + +$COMPILE{admin_user_table_add} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_table_add { +#------------------------------------------------------------- +# Add a field +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + return ('admin_user_table_add.html') if ($IN->param('form')); + + my $db = $DB->table('Users'); + my %cols = $db->cols; + my $attribs = _col_spec(); + my $column = 'pro_'.$IN->param('column'); + +# Error checking + my $errors = _field_check(); + if ( exists $cols{$column} ) { + $errors .= sprintf(GList::language('TAB_COL_EXISTS'), $column); + } + if ( $IN->param('index') eq 'primary' ) { + $errors .= GList::language('TAB_PRIMARY_ERR'); + } + return ('admin_user_table_add.html', { msg => "$errors" }) if ($errors); + + $attribs->{pos} = keys(%cols) + 1; + $attribs->{edit} = 1; + $attribs->{default} ||= ''; + my $editor = $DB->editor('Users'); + +# Add the column. + delete $attribs->{column}; + $editor->add_col($column, $attribs) or return ('admin_user_table_add.html', { msg => GList::language('TAB_ADD_COLUMN_ERR', $column, $GT::SQL::error) }); + +# Add the indexes. + if ( $IN->param('index') eq 'regular' ) { + $editor->add_index($column . '_idx' => [$column]) or return ('admin_user_table_add.html', { msg => GList::language('TAB_ADD_INDEX_ERR', $GT::SQL::error) }); + } + if ( $IN->param('index') eq 'unique' ) { + $editor->add_index($column . '_idx' => [$column]) or return ('admin_user_table_add.html', { msg => GList::language('TAB_ADD_UNIQUE_ERR', $GT::SQL::error) }); + } + $db->reload; + + return admin_user_table(GList::language('TAB_ADD_SUCCESS', $column)); +} +END_OF_SUB + +$COMPILE{admin_user_table_modify} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_table_modify { +#------------------------------------------------------------- +# Modify a field +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $col = $IN->param('column'); + my $db = $DB->table('Users'); + my $editor = $DB->editor('Users'); + my $cols = $db->cols; + my $old_def = $cols->{$col}; + return admin_user_table(GList::language('TAB_MOD_ERR', $col)) if (!exists $cols->{$col} or !$col); + + my %attribs = %{$cols->{$col}}; + +# Set up defaults for the fields + foreach my $col (qw/column type not_null file_save_in file_max_size file_save_scheme default form_display form_type form_size form_names form_values regex weight values size/) { + $attribs{$col} = $IN->param($col) if ( defined $IN->param($col) ); + } + + $attribs{column} ||= $col; + $attribs{form_type} ||= 'TEXT'; + $attribs{form_size} ||= ($attribs{form_type} eq 'SELECT') ? 0 : ''; + ref $attribs{form_size} and ($attribs{form_size} = join(",", @{$attribs{form_size}})); + ref $attribs{form_names} and ($attribs{form_names} = join("\n", @{$attribs{form_names}})); + ref $attribs{form_values} and ($attribs{form_values} = join("\n", @{$attribs{form_values}})); + ref $attribs{values} and ($attribs{values} = join("\n", @{$attribs{values}})); + return ('admin_user_table_modify.html', \%attribs) if ($IN->param('form')); + +# Keep any values that where there before + my $attribs = _col_spec(); + for my $val ( keys %$old_def ) { + $attribs->{$val} = $old_def->{$val} unless exists $attribs->{$val}; + } + +# Error checking + my $errors = _field_check(); + if ( $IN->param('index') eq 'primary' and ( $col ne $db->{schema}->{pk}) ) { + $errors .= GList::language('TAB_PRIMARY_ERR'); + } + return ('admin_user_table_modify.html', { msg => "$errors", %attribs }) if($errors); + +# Add/Drop indexes. + my $index_type = _index_type($col); + if ( $index_type ne $IN->param('index') ) { + if ($index_type eq 'none') { + if ( $IN->param('index') eq 'regular' ) { + $editor->add_index( $col . "_idx" => [$col] ); + } + else { + $editor->add_unique( $col . "_idx" => [$col] ); + } + } + elsif ( $IN->param('index') eq 'none' ) { + if ( $index_type eq 'regular' ) { + my $index = $db->index; + INDEX: foreach my $index_name (keys %$index) { + foreach my $col_name ( @{$index->{$index_name}} ) { + next unless ($col_name eq $col); + $editor->drop_index($index_name) or return ('admin_user_table_modify.html', { msg => "$GT::SQL::error", %attribs }); + last INDEX; + } + } + } + else { + my $unique = $db->unique; + INDEX: foreach my $unique_name (keys %$unique) { + foreach my $col_name (@{$unique->{$unique_name}}) { + next unless ($col_name eq $col); + $editor->drop_unique($unique_name) or return ('admin_user_table_modify.html', { msg => "$GT::SQL::error", %attribs }); + last INDEX; + } + } + } + } + } + +# Make the changes + delete $attribs->{column}; + + $editor->alter_col($col, $attribs) or return ('admin_user_table_modify.html', { msg => ''.$editor->error.'', %attribs }); + return admin_user_table(GList::language('TAB_MOD_SUCCESS', $col)); +} +END_OF_SUB + +$COMPILE{admin_user_table_delete} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_table_delete { +#-------------------------------------------------------------- +# Delete a field of User Table +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +#------------demo code----------- + + my $column = $IN->param('column'); + return admin_user_table(GList::language('TAB_MOD_INVALID')) if (!$column); + return admin_user_table(GList::language('TAB_MOD_PERMIT_ERR', 'pro_first_name, pro_last_name')) if ($column =~ /pro_first_name|pro_last_name/); + +# Keep any values that where there before + my $db = $DB->table('Users'); + my $editor = $DB->editor('Users'); + my $old_def = $db->cols->{$column}; + +# Drop the column from the database. + $editor->drop_col($column) or return admin_user_table("$GT::SQL::error"); + + return admin_user_table(GList::language('TAB_DEL_SUCCESS', $column)); +} +END_OF_SUB + +$COMPILE{admin_user_table_resync} = __LINE__ . <<'END_OF_SUB'; +sub admin_user_table_resync { +#-------------------------------------------------------------------- +# Resync database +# + my $name = $IN->param('db') || 'Users'; + $USER->{usr_type} == ADMINISTRATOR or return ('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + +# We need a creator for this. + my $c = $DB->creator($name); + my $db = $DB->table($name); + $c->load_table or return admin_user_table($GT::SQL::error); + +# Re Load our table object. + $db->reload; + + return admin_user_table(GList::language('TAB_RESYNC')); +} +END_OF_SUB + +$COMPILE{admin_stoplist} = __LINE__ . <<'END_OF_SUB'; +sub admin_stoplist { +#------------------------------------------------------------------- +# Update the stop lists +# + my $msg = shift; + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + $MN_SELECTED = 9; + return ('admin_stoplist_form.html') if ($IN->param('form')); + + my $alpha = 0; + my $cgi = $IN->get_hash; + my $query= ''; + if ($IN->param('alpha') and $IN->param('alpha') ne 'all') { # from the quick search bar + $alpha = $IN->param('alpha'); + $query = "alpha=$alpha"; + } + my $db = $DB->table('StopLists'); + $db->select_options('ORDER BY letter'); + + require GT::SQL::Condition; + my $cd = GT::SQL::Condition->new(); + my $url = 'glist.cgi?do=admin_stoplist'; + if ($cgi->{stl_email}) { + $cd->add('stl_email' => 'like' => "%$cgi->{stl_email}%"); + $url .= ";stl_email=$cgi->{stl_email}"; + } + + my $sth = $db->select($cd, ['DISTINCT SUBSTRING(stl_email, 1, 1) as letter']); + my $results = GList::search( + cgi => $cgi, + db => $DB->table('StopLists'), + based_on => $DB->prefix.'StopLists', + prefix => 'stl', + sb => 'stl_email', + so => 'ASC', + search_alpha=> $alpha, + search_col => 'stl_email', + return_msg => 'ADM_STOPLIST', + skip_user => 1, + ); + + require GList::List; + if ( ref $results ne 'HASH' ) { + return ('admin_stoplist.html', { search_bar => GList::List::_search_bar($sth, $url), msg => $results }); + } + $results->{msg} = $msg if ($msg); + return ('admin_stoplist.html', { search_bar => GList::List::_search_bar($sth, $url), toolbar_query => $query, toolbar_table => 'StopLists', %$results }) +} +END_OF_SUB + +$COMPILE{admin_stoplist_confirm} = __LINE__ . <<'END_OF_SUB'; +sub admin_stoplist_confirm { +#-------------------------------------------------------------------- +# Confirmation about remove all emails that match the addition stoplist +# from all list +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + $MN_SELECTED = 9; + my $emails = $IN->param('emails') || ''; + return ('lst_stoplist_form.html', { msg => GList::language('ADM_STOPLIST_ERROR') }) if (!$emails); + + require GT::SQL::Condition; + my $db_sub = $DB->table('Subscribers'); + my @emails = split(/\r?\n/, $emails); + + my (@results, %found); + foreach my $e (@emails) { + $e =~ s/^\s+//; + $e =~ s/\s+$//; + next unless $e and $e =~ /.@./; + my $cond; + if ($e =~ /[*?]/) { + my $tmp = $e; + $tmp =~ y/*/%/; + $tmp =~ y/?/_/; + $cond = GT::SQL::Condition->new(sub_email => LIKE => $tmp); + } + else { + $cond = { sub_email => $e }; + } + my $pre = keys %found; + my @found = $db_sub->select(sub_id => $cond)->fetchall_list; + for (@found) { $found{$_}++ } + my $added = keys(%found) - $pre; + push @results, { email => $e, found => $added }; + } + + my $found_emails = scalar keys %found; + return admin_stoplist_add() if (!$found_emails); + + return ('admin_stoplist_form.html', { + loop_results => \@results, + loop_hits => $#results + 1, + found_emails => $found_emails, + data => $emails, + confirmation => 1 + }); +} +END_OF_SUB + +$COMPILE{admin_stoplist_add} = __LINE__ . <<'END_OF_SUB'; +sub admin_stoplist_add { +#-------------------------------------------------------------------- +# Add email to stop list +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + $MN_SELECTED = 9; + my $emails = $IN->param('emails') || ''; + return ('lst_stoplist_form.html', { msg => GList::language('ADM_STOPLIST_ERROR') }) if (!$emails); + + my ($invalid, $duplicate) = (0, 0); + my @emails = split(/\r?\n/, $emails); + my $db_stl = $DB->table('StopLists'); + my $db_sub = $DB->table('Subscribers'); + + require GT::SQL::Condition; + my @results; + my $cond = GT::SQL::Condition->new('OR'); + foreach my $e (@emails) { + $e =~ s/^\s+//; + $e =~ s/\s+$//; + next if !$e; + if ( $e !~ /.@./ ) { # check email address + push @results, { email => $e, status => GList::language('SYS_INVALID_EMAIL') }; + $invalid++; + } + else { + if ($e =~ /[*?]/) { + my $tmp = $e; + $tmp =~ y/*/%/; + $tmp =~ y/?/_/; + $cond->add(sub_email => LIKE => $tmp); + } + else { + $cond->add(sub_email => '=' => $e); + } + + push @results, { email => $e, status => '' }; + if ($db_stl->count({ stl_email => $e })) { + $results[-1]->{status} = GList::language('SYS_DUPLICATE'); + $duplicate++; + } + else { + $db_stl->insert({ stl_email => $e }); + } + } + } + $db_sub->delete($cond) if (@{$cond->{cond}}); + + return ('admin_stoplist_success.html', { + results => \@results, + duplicate => $duplicate, + invalid => $invalid, + hits => scalar @results, + successful => scalar @results - $invalid - $duplicate, + }); +} +END_OF_SUB + +$COMPILE{admin_stoplist_delete} = __LINE__ . <<'END_OF_SUB'; +sub admin_stoplist_delete { +#--------------------------------------------------------------------- +# Delete email from stop list +# + $USER->{usr_type} == ADMINISTRATOR or return GList::display('error_form.html', { msg => GList::language('ADM_PERMISSION_ERR') }); + + my $mod = ( ref $IN->param('modify') eq 'ARRAY' ) ? $IN->param('modify') : [$IN->param('modify')]; + my $db = $DB->table('StopLists'); + my $cgi = $IN->get_hash(); + + foreach my $rec_num ( @{$mod} ) { + $db->delete({ stl_id => $cgi->{"$rec_num-stl_id"} }); + } + return admin_stoplist(GList::language('ADM_STOPLIST_DELETED', $#$mod + 1)); +} +END_OF_SUB + +$COMPILE{_update_cfg} = __LINE__ . <<'END_OF_SUB'; +sub _update_cfg { +# ------------------------------------------------------------------ +# Updates the config based on the form input. +# + foreach my $param ($IN->param) { + if (exists $CFG->{$param}) { + if (ref $CFG->{$param} eq ref []) { + my @val = split /\s*,\s*/, $IN->param($param); + $CFG->{$param} = \@val; + } + elsif (ref $CFG->{$param} eq ref {}) { + my $h = {}; + my @pairs = split /\s*,\s*/, $IN->param($param); + foreach my $pair (@pairs) { + my ($k, $v) = split /\s*=\s*/, $pair; + $h->{$k} = $v; + } + $CFG->{$param} = $h; + } + else { + $CFG->{$param} = $IN->param($param); + } + } + } +} +END_OF_SUB + +$COMPILE{_field_check} = __LINE__ . <<'END_OF_SUB'; +sub _field_check { +# ---------------------------------------------------------- +# Checks to see if the input field name is a valid one, +# the function checks the following: +# 1. Column name +# 2. Check column exist +# 3. Check field size + my $cgi = $IN->get_hash; + my $col_name = $cgi->{column} || $cgi->{mod}; + my $form_type = uc($cgi->{form_type}); + my $type = uc($cgi->{type}); + + return GList::language('TAB_COL_NAME') if ( $col_name !~ /^(\w+)$/ ); + +# Max lengths + if (( $type eq 'CHAR' ) and ( $cgi->{size} > 255 ) ) { + return GList::language('TAB_COL_SIZE'); + } + + if ( ( $type eq 'INT' ) and ( $cgi->{size} > 0 ) ) { + return GList::language('TAB_COL_SIZE_INT'); + } + + if ( ( $type eq 'ENUM' ) and ( !$cgi->{values} ) ) { + return GList::language('TAB_COL_VALUES'); + } + + if ( ( $cgi->{index} eq 'primary' or $cgi->{index} eq 'index' or $cgi->{index} eq 'unique' ) and ( ! $cgi->{not_null} ) ) { + return sprintf(GList::language('TAB_COL_NOTNULL'), $col_name); + } + + if ( ( $form_type eq 'FILE' ) and ( $type ne 'CHAR' ) and ( $type ne 'VARCHAR' ) ) { + return GList::language('TAB_COL_FILE_TYPE'); + } + + my $location = $cgi->{file_save_in}; + if ( ( $form_type eq 'FILE' ) and ( !$location ) ) { + return GList::language('TAB_COL_FILE_IN'); + } + + if ( ( $form_type eq 'FILE' ) and ( !-w $location ) ) { + return sprintf(GList::language('TAB_COL_FILE_ERR'), $location); + } +} +END_OF_SUB + +$COMPILE{_col_spec} = __LINE__ . <<'END_OF_SUB'; +sub _col_spec { +# ---------------------------------------------------------- +# Reconstruct the input variables into a string in the form +# "field_name(type(length_set) attribute DEFAULT default_value extra)" + + my $cgi = $IN->get_hash; + my $col_spec; + + # add field properties into a hash + $col_spec->{'type'} = $cgi->{type}; + if ( $cgi->{type} eq 'ENUM' ) { + $col_spec->{'values'} = [split /(?:\n|\r)+/, $cgi->{values}]; + } + else { + $col_spec->{'size'} = $cgi->{size}; + } + $col_spec->{'default'} = $cgi->{default}; + $col_spec->{'not_null'} = ($cgi->{not_null}) ? '1' : ''; + $col_spec->{'form_display'} = ($cgi->{form_display})? $cgi->{form_display} : $cgi->{column}; + $col_spec->{'form_type'} = ($cgi->{form_type}) ? $cgi->{form_type} : 'TEXT'; + $col_spec->{'form_size'} = ($cgi->{form_size}) ? $cgi->{form_size} : ''; + $col_spec->{'form_names'} = ($cgi->{form_names}) ? [split /(?:\n|\r)+/, $cgi->{form_names}] : []; + $col_spec->{'form_values'} = ($cgi->{form_values}) ? [split /(?:\n|\r)+/, $cgi->{form_values}]: []; + $col_spec->{'regex'} = ($cgi->{regex}) ? $cgi->{regex} : ''; + + if ( $cgi->{file_save_in} ) { + $col_spec->{'file_save_in'} = $cgi->{file_save_in}; + $col_spec->{'file_save_scheme'} = $cgi->{file_save_scheme}; + $col_spec->{'file_max_size'} = $cgi->{file_max_size}; + } + + return $col_spec; +} +END_OF_SUB + +$COMPILE{_index_type} = __LINE__ . <<'END_OF_SUB'; +sub _index_type { +#----------------------------------------------------------------- + my $column = shift; + my $db = $DB->table('Users'); + my $indexed = 'none'; + if ($column) { + $db->_is_indexed($column) and ($indexed = 'regular'); + $db->_is_unique($column) and ($indexed = 'unique'); + $db->_is_pk($column) and ($indexed = 'primary'); + } + return $indexed; +} +END_OF_SUB + +$COMPILE{_save_users} = __LINE__ . <<'END_OF_SUB'; +sub _save_users { +#------------------------------------------------------------------- +# + my $users = $DB->table('Users')->select({ usr_type => ADMINISTRATOR }, ['usr_username', 'usr_password', 'usr_email'])->fetchall_hashref; + my %hash; + foreach (@$users) { + $hash{$_->{usr_username}} = [$_->{usr_password}, $_->{usr_email}]; + } + $CFG->{admin} = \%hash; + $CFG->save; +} +END_OF_SUB + +$COMPILE{_sql_load_cfg} = __LINE__ . <<'END_OF_SUB'; +sub _sql_load_cfg { +#------------------------------------------------------------------- +# Load current sql information +# + require GList::SQL; + my $cfg = GList::SQL::load(); + foreach (keys % $cfg) { + $cfg->{"sql_$_"} = $cfg->{$_}; + delete $cfg->{$_}; + } + return $cfg; +} +END_OF_SUB + +$COMPILE{_sql_connect} = __LINE__ . <<'END_OF_SUB'; +sub _sql_connect { +#---------------------------------------------------------- +# + my ($host, $driver, $database, $login, $password, $prefix) = @_; + + my ($port, $ret); + ($host =~ s/\:(\d+)$//) and ($port = $1); + + $prefix =~ /^\w*$/ or return { error => "Invalid prefix: '$prefix'. Can only be letters, numbers and underscore." }; + + GT::SQL->reset_env(); + $DB->prefix($prefix); + $ret = $DB->set_connect({ + driver => $driver, + host => $host, + port => $port, + database => $database, + login => $login, + password => $password, + RaiseError => 0, + PrintError => 0, + AutoCommit => 1 + }); + + if (! defined $ret) { + return { error => "$GT::SQL::error" }; + } + + return $ret; +} +END_OF_SUB + +$COMPILE{_account_limit} = __LINE__ . <<'END_OF_SUB'; +sub _account_limit { +#----------------------------------------------------------- +# + my $data = shift; + if ($data->{usr_type} == ADMINISTRATOR or $data->{usr_type} == UNLIMITED_USER ) { + $data->{usr_limit_list} = 0; + $data->{usr_limit_sublist} = 0; + $data->{usr_limit_email30} = 0; + } + else { + $data->{usr_limit_list} ||= $CFG->{signup_limit_list} || 10; + $data->{usr_limit_sublist} ||= $CFG->{signup_limit_sublist} || 10; + $data->{usr_limit_email30} ||= $CFG->{signup_limit_email30} || 100; + } + return $data; +} +END_OF_SUB + +$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB'; +sub _determine_action { +#---------------------------------------------------------------------------- +# Check valid action +# + my $action = shift || undef; + + if ( $action =~ /admin_setup_sql_form|admin_setup_sql|admin_setup_form|admin_setup/ ) { + $MN_SELECTED = 9; + } + ($action eq 'admin_user_search') and return 'admin_user'; + return if ( !$action ); + + my %valid = ( + map { $_ => 1 } qw( + admin_gtdoc + admin_page + admin_initial_sql + admin_initial_setup + admin_user + admin_user_add + admin_user_modify_form + admin_user_modify + admin_user_delete + admin_user_validate + admin_user_table + admin_user_table_add + admin_user_table_modify + admin_user_table_delete + admin_user_table_resync + admin_plugin + admin_setup_sql_form + admin_setup_sql + admin_setup_form + admin_setup + admin_template_diff + admin_stoplist + admin_stoplist_add + admin_stoplist_confirm + admin_stoplist_delete + ) + ); + exists $valid{$action} and return $action; + return; +} +END_OF_SUB + +1; diff --git a/site/glist/lib/GList/Authenticate.pm b/site/glist/lib/GList/Authenticate.pm new file mode 100644 index 0000000..971a1d7 --- /dev/null +++ b/site/glist/lib/GList/Authenticate.pm @@ -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; diff --git a/site/glist/lib/GList/Config.pm b/site/glist/lib/GList/Config.pm new file mode 100644 index 0000000..63dbd75 --- /dev/null +++ b/site/glist/lib/GList/Config.pm @@ -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'; + +
+Join <%name%>!
+Email Address:
+Name:
+ + +
+ +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; + diff --git a/site/glist/lib/GList/Config/Data.pm b/site/glist/lib/GList/Config/Data.pm new file mode 100644 index 0000000..a8acd49 --- /dev/null +++ b/site/glist/lib/GList/Config/Data.pm @@ -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' => ' +
+Join <%name%>!
+Email Address:
+Name:
+ + + +
+ + ', + '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 diff --git a/site/glist/lib/GList/Custom.pm b/site/glist/lib/GList/Custom.pm new file mode 100644 index 0000000..1dafc01 --- /dev/null +++ b/site/glist/lib/GList/Custom.pm @@ -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 diff --git a/site/glist/lib/GList/GUI.pm b/site/glist/lib/GList/GUI.pm new file mode 100644 index 0000000..3049a82 --- /dev/null +++ b/site/glist/lib/GList/GUI.pm @@ -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}>{td_l}>
    $title{td_r}>$$input_html $opts->{required}" : + "{tr}>{td_l}>
      $title{td_r}>$$input_html"; + } + 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 / + + ~; + } : + $disp->text($opts); + + return \$input_html; +} + +sub gui_toolbar { + my %input = @_; + my $tags = GT::Template->tags; + $input{first} ||= q|First page|; + $input{first_grey} ||= q|First page|; + $input{prev} ||= q|Previous page|; + $input{prev_grey} ||= q|Previous page|; + $input{next} ||= q|Next page|; + $input{next_grey} ||= q|Next page|; + $input{last} ||= q|Last page|; + $input{last_grey} ||= q|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||; + $input{after_current} ||= q||; + $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|$disp\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; diff --git a/site/glist/lib/GList/HTML.pm b/site/glist/lib/GList/HTML.pm new file mode 100644 index 0000000..f1bece3 --- /dev/null +++ b/site/glist/lib/GList/HTML.pm @@ -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/
      /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; + + diff --git a/site/glist/lib/GList/List.pm b/site/glist/lib/GList/List.pm new file mode 100644 index 0000000..6a8135f --- /dev/null +++ b/site/glist/lib/GList/List.pm @@ -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 => "$GList::error", 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("$GList::error") 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 = ; + 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') ) ? "$_ " : "$_ "; + } + elsif ($items->{$_}) { + my $l = ($_ eq '0..9') ? 'number' : lc $_; + $search_bar .= ( lc $current eq lc $l ) ? "$_ " : "$_ "; + } + 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; + + diff --git a/site/glist/lib/GList/Mailer.pm b/site/glist/lib/GList/Mailer.pm new file mode 100644 index 0000000..b584712 --- /dev/null +++ b/site/glist/lib/GList/Mailer.pm @@ -0,0 +1,1076 @@ +# ================================================================== +# Gossamer List - enhanced mailing list management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : +# Revision : $Id: Mailer.pm,v 1.79 2005/04/06 23:17:03 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::Mailer; + +use strict; +use GList qw/:user_type :objects :tracks $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); + + $MN_SELECTED = 3; + if ($tpl) { + my $hidden = GList::hidden(); + $results->{hidden_query} = $hidden->{hidden_query}; + $results->{hidden_objects} = $hidden->{hidden_objects}; + GList::display($tpl, $results); + } +} + +sub mli_print { +#-------------------------------------------------------------------- +# + my ($page, $args) = @_; + +# Get category's information + my $nav = _load_navigator() || {}; + my ($info, $url); + if ($IN->param('id')) { + $info = ( $USER->{usr_type} == ADMINISTRATOR ) ? $DB->table('CatMailing')->get({ cm_id => $IN->param('id') }) + : $DB->table('CatMailing')->get({ cm_id => $IN->param('id'), cm_user_id_fk => $USER->{usr_username} }); + } + $info ||= {}; + +# Create the URL + my @items = ('cd', 'cs', 'ca'); + foreach (@items) { + $url .= "$_=".$IN->param($_).'&' if ($IN->param($_)); + } + return ($page, { %$info, %$nav, %$args, url => $url }); +} + +$COMPILE{mli_home} = <<'END_OF_SUB'; +sub mli_home { +#-------------------------------------------------------------------- +# Print home page +# + my ($msg, $cgi) = @_; + + $cgi ||= $IN->get_hash; + $msg ||= GList::language('MLI_SUCCESS', $cgi->{sent}) if ($cgi->{sent}); + $msg = GList::language('MLI_BOUNCED_EMAILS', $cgi->{bounced}) if ($cgi->{bounced}); + if ($cgi->{do} =~ /msg_send|mli_bounced/) { + $cgi->{fd} = 1; + } + +#------------demo code----------- + + if (!$cgi->{d}) { + if ( $cgi->{fd} and $cgi->{fd} =~ /^1|2/ ) { # Queue & Sent Items + $cgi->{mli_delete} = 1; + $cgi->{'mli_delete-opt'}= '<'; + $cgi->{mli_done} = 1; + $cgi->{'mli_done-opt'} = ( $cgi->{fd} == 2 ) ? '>' : '<'; + $cgi->{mli_scheduled} = 0; + if ( $cgi->{fd} == 2 and $cgi->{do} ne 'mli_search' ) { + $cgi->{mli_cat_id_fk} = ( $cgi->{id} ) ? $cgi->{id} : 0; + } + } + elsif ( $cgi->{fd} == 3 ) { # Delete Items + $cgi->{mli_delete} = 1; + } + elsif ($cgi->{fd} == 4) { # Scheduled mailings + $cgi->{mli_scheduled} = 1; + $cgi->{mli_delete} = 0; + } + } + my $search_check = ($IN->param('do') eq 'mli_search') ? 1 : 0; + if ($cgi->{'mli_done-ge'} or $cgi->{'mli_done-le'}) { + my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%'; + my ($valid_from, $valid_to) = (1, 1); + + require GT::Date; + if ($cgi->{'mli_done-ge'}) { + $valid_from = GList::date_to_time($cgi->{'mli_done-ge'}, $format); + $cgi->{'mli_done-ge'} = GT::Date::date_get($valid_from, $format); + } + if ($cgi->{'mli_done-le'}) { + $valid_to = GList::date_to_time($cgi->{'mli_done-le'}, $format); + $cgi->{'mli_done-le'} = GT::Date::date_get($valid_to, $format); + } + + if ($search_check and (!$valid_from or !$valid_to)) { + $format =~ s/\%//g; + return ('mli_search_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) }); + } + } + if ($IN->param('do') eq 'mli_search' and $IN->param('fd') and $IN->param('fd') !~ /^1|2|3/) { + my @cat = split(/\-/, $IN->param('fd')); + $cgi->{mli_cat_id_fk} = $cat[1]; + } + my $results = GList::search( + cgi => $cgi, + db => $DB->table('MailingIndex'), + prefix => 'mli', + sb => 'mli_id', + so => 'DESC', + search_check=> $search_check + ); +# Get category's information + my $info = {}; + if ($IN->param('id')) { + $info = ( $USER->{usr_type} == ADMINISTRATOR ) ? $DB->table('CatMailing')->get({ cm_id => $IN->param('id') }) + : $DB->table('CatMailing')->get({ cm_id => $IN->param('id'), cm_user_id_fk => $USER->{usr_username} }); + $info ||= {}; + } + + my $nav = _load_navigator() || {}; + +# Create the URL + my $url; + my @items = ('cd', 'cs', 'ca'); + foreach ( @items ) { + $url .= "$_=".$cgi->{$_}.'&' if ( $cgi->{$_} ); + } + chop $url if ($url); + + if ( ref $results ne 'HASH' ) { + ( $IN->param('do') eq 'mli_search' ) ? return ('mli_search_form.html', { msg => $msg || $results, %$nav, %$info, url => $url }) + : return ('mli_home.html', { msg => $msg || $results, %$nav, %$info, url => $url }); + } + elsif ( $results->{error} and $search_check ) { + return ('mli_search_form.html', { msg => $results->{error} }); + } + + my $eml = $DB->table('EmailMailings'); + my $output = $results->{results}; + + require GT::SQL::Condition; + foreach my $rs ( @$output ) { + my $cd_sent = GT::SQL::Condition->new( + eml_mailing_id_fk => '=' => $rs->{mli_id}, + eml_sent => '<>' => 0 + ); + $rs->{total} = $eml->count({ eml_mailing_id_fk => $rs->{mli_id} }); + $rs->{bounced_emails} = $eml->count({ eml_mailing_id_fk => $rs->{mli_id}, eml_bounced => 1 }); + $rs->{done} = $eml->count($cd_sent); + } + $results->{msg} = $msg if ($msg); + return ('mli_home.html', { %$results, %$nav, %$info, url => $url }); +} +END_OF_SUB + +$COMPILE{mli_search_form} = <<'END_OF_SUB'; +sub mli_search_form { +#-------------------------------------------------------------------- +# Print the search form +# + my $msg = shift; + return mli_print('mli_search_form.html', { msg => $msg }); +} +END_OF_SUB + +$COMPILE{mli_empty} = <<'END_OF_SUB'; +sub mli_empty { +#-------------------------------------------------------------------- +# Delete all of deleted items +# + require GT::SQL::Condition; + my $db = $DB->table('MailingIndex'); + my $cd = new GT::SQL::Condition; + $cd->add('mli_delete', '=', 1); + + if ($USER->{usr_type} == ADMINISTRATOR and $IN->param('users')) { # As a admin user + $cd->add('mli_user_id_fk', '<>', $USER->{usr_username}); + } + else { + $cd->add('mli_user_id_fk', '=', $USER->{usr_username}); + } + $db->delete($cd); + + mli_home(GList::language('MLI_EMPTY')); +} +END_OF_SUB + +$COMPILE{mli_delete} = <<'END_OF_SUB'; +sub mli_delete { +#-------------------------------------------------------------------- +# Delete the mailings +# + return mli_home(GList::delete('MailingIndex', 'mli')); +} +END_OF_SUB + +$COMPILE{mli_move} = <<'END_OF_SUB'; +sub mli_move { +#-------------------------------------------------------------------- +# Moves the records to another category +# + ( $IN->param('modify') ) or return mli_home(GList::language('SYS_MOVE_ERR')); + +# Check category ID + my $to = $IN->param('move_to'); + ( $to) or return mli_home(GList::language('SYS_TARGET_ERR')); + + if ( $to ne 'root' and $to ne 'draft' and $to ne 'sent') { # Move to a sub-category + my $info = GList::check_owner('CatMailing', 'cm', $to); + ( ref $info eq 'HASH' ) or return mli_home($info); + } + +# Need to know the number of records modified + my $rec_modified = 0; + my $rec_declined = 0; + + my $mod = ( ref $IN->param('modify') eq 'ARRAY' ) ? $IN->param('modify') : [$IN->param('modify')]; + my $db = $DB->table('MailingIndex'); +# For through the record numbers. These are the values of the check boxes + foreach my $rec_num ( @$mod ) { + my $change = {}; + $change->{mli_id} = $IN->param("$rec_num-mli_id") if ($IN->param("$rec_num-mli_id")); + +# Check if users can modify only their own records except Administrator + my $rs = $db->get($change); + if ( $USER->{usr_type} != ADMINISTRATOR ) { + next if ( !$rs ); + if ( $rs->{'mli_user_id_fk'} ne $USER->{usr_username} ) { + $rec_declined++; next; + } + } + next unless ( keys %$change ); + next if ($to eq 'draft' and $rs->{mli_done}); + next if ($to eq 'sent' and !$rs->{mli_done}); + + my $ret; + if ( $to =~ /^root|draft|sent/mi ) { + $ret = ( $IN->param('fd') == 3 ) ? $db->update({ mli_cat_id_fk => 0, mli_delete => '0' }, $change) + : $db->update({ mli_cat_id_fk => 0 }, $change); + } + else { + $ret = $db->update({ mli_cat_id_fk => $to }, $change); + } + $rec_modified++ if (defined $ret and $ret != 0); + } + mli_home(($rec_declined) ? GList::language('SYS_MOVED2', $rec_modified, $rec_declined) : GList::language('SYS_MOVED', $rec_modified)); +} +END_OF_SUB + + +$COMPILE{mli_send} = __LINE__ . <<'END_OF_SUB'; +sub mli_send { +#-------------------------------------------------------------------- +# Send Email - Send email to subcribers +# + return mli_home(GList::language('MLI_INVALID')) if (!$IN->param('modify')); + + $MN_SELECTED = 3; + +# Check account limits + my $num_sent = GList::check_limit('email30') || 0; + return mli_home(GList::language('SYS_OVERLIMIT_EMAIL30')) if ($num_sent == 1); + + my $mod = (ref $IN->param('modify') eq 'ARRAY') ? $IN->param('modify') : [$IN->param('modify')]; + my @ids = map $IN->param("$_-mli_id"), @{$mod}; + + my $total_size = _size_mailings(\@ids, 'web'); + return mli_home(GList::language('MLI_MSG_EMPTY')) if (!$total_size); + + _send('web', \@ids, $total_size); + return; +} +END_OF_SUB + +$COMPILE{mli_fview} = <<'END_OF_SUB'; +sub mli_fview { +#-------------------------------------------------------------------- +# Print a attached file +# + return GList::view_file(); +} +END_OF_SUB + +$COMPILE{mli_fdownload} = <<'END_OF_SUB'; +sub mli_fdownload { +#-------------------------------------------------------------------- +# Print a attached file +# + return GList::download_file(); +} +END_OF_SUB + +$COMPILE{mli_bounced_form} = <<'END_OF_SUB'; +sub mli_bounced_form { +#-------------------------------------------------------------------- +# + my ($msg, $page) = @_; + $page ||= 'mli_check_bounced_form.html'; + $page = 'mli_check_bounced_results.html' if ($IN->param('results')); + + return mli_print($page, { msg => $msg }); +} +END_OF_SUB + +$COMPILE{mli_bounced} = <<'END_OF_SUB'; +sub mli_bounced { +#-------------------------------------------------------------------- +# To check a pop account and delete bounced emails +# + +#------------demo code----------- + + return mli_bounced_form(GList::language('MLI_BOUNCED_NO_SERVER')) unless ($IN->param('mail_host')); + return mli_bounced_form(GList::language('MLI_BOUNCED_NO_USER')) unless ($IN->param('mail_user')); + return mli_bounced_form(GList::language('MLI_BOUNCED_NO_PASS')) unless ($IN->param('mail_pass')); + + _bounced('web', { + host => $IN->param('mail_host'), + port => $IN->param('mail_port') || 110, + user => $IN->param('mail_user'), + pass => $IN->param('mail_pass'), + auth_mode => 'PASS', + debug => $CFG->{debug_level} + }, { delete => $IN->param('del_bounced'), save => $IN->param('save_info') }); +} +END_OF_SUB + +$COMPILE{mli_recipients} = <<'END_OF_SUB'; +sub mli_recipients { +#------------------------------------------------------------------- +# View recipients +# + my $id = $IN->param('eml_mailing_id_fk'); + return mli_home(GList::language('MLI_INVALID')) if (!$id); + +# Check the record's onwer + my $mli = $DB->table('MailingIndex')->get($id); + return mli_home(GList::language('MLI_NOT_FOUND', $id)) if (!$mli); + + if ( $USER->{usr_type} != ADMINISTRATOR ) { # As a user + my $cond = new GT::SQL::Condition('OR'); + + $cond->add('usr_username', '=', $mli->{mli_user_id_fk}); + my $u = $DB->table('Users')->select($cond)->rows; + return mli_home(GList::language('SYS_PER_DENIED')) if (!$u); + } + + my $cgi = $IN->get_hash; + $cgi->{eml_mailing_id_fk} = $id; + my $results = GList::search( + cgi => $cgi, + db => $DB->table('EmailMailings'), + skip_user => 1, + prefix => 'eml', + sb => 'eml_email', + so => 'ASC', + ); + + if ( ref $results ne 'HASH' ) { + return ('mli_recipients.html', %$results); + } + return ('mli_recipients.html', $results); +} +END_OF_SUB + +$COMPILE{mli_cat_add} = <<'END_OF_SUB'; +sub mli_cat_add { +#-------------------------------------------------------------------- +# Add a category +# + my $name = $IN->param('cm_name'); + ( $name ) or return mli_home(GList::language('SYS_ADD_INVALID')); + + my $ret = GList::add('CatMailing', 'cm', { cm_name => $name, cm_type => 2 }); + return mli_home($GList::error) if ($GList::error); + + return mli_home(GList::language('DIR_ADDED', $name)) if ( $ret ); +} +END_OF_SUB + +$COMPILE{mli_cat_modify} = <<'END_OF_SUB'; +sub mli_cat_modify { +#------------------------------------------------------------------- +# Update a category +# + my $id = $IN->param('cm_id'); + ( $id ) or return mli_home(GList::languag('SYS_ADD_INVALID')); + + GList::modify('CatMailing', 'cm'); + + return mli_home($GList::error) if ($GList::error); + mli_home(GList::language('DIR_UPDATED', $IN->param('cm_name'))); +} +END_OF_SUB + +$COMPILE{mli_cat_delete} = <<'END_OF_SUB'; +sub mli_cat_delete { +#-------------------------------------------------------------------- +# Delete a category +# + my $cgi = $IN->get_hash(); + + ( $cgi->{cm_id}) or return mli_home(GList::languag('SYS_ADD_INVALID')); + + $cgi->{modify} = '1'; + $cgi->{'1-cm_id'} = $cgi->{cm_id}; + if ( $USER->{usr_type} != ADMINISTRATOR ) { + my $owner = $DB->table('CatMailing')->select({ cm_user_id_fk => $USER->{usr_username} }, ['cm_user_id_fk'])->fetchrow_array; + ( !$owner or $owner ne $USER->{usr_username} ) and return mli_home(GList::language('SYS_PER_DENIED')); + } + + $DB->table('MailingIndex')->update({ mli_cat_id_fk => 0, mli_delete => '1' }, { mli_cat_id_fk => $cgi->{cm_id} }); + + return mli_home(GList::delete('CatMailing', 'cm', $cgi, GList::language('DIR_DELETED', $IN->param('cm_name')))); +} +END_OF_SUB + +$COMPILE{mli_schedule} = __LINE__ . <<'END_OF_SUB'; +sub mli_schedule { +#-------------------------------------------------------------------- +# + return mli_home() if $IN->param('bcancel'); + + my $mod = ref $IN->param('modify') eq 'ARRAY' ? $IN->param('modify') : [$IN->param('modify')]; + my @ids = map $IN->param("$_-mli_id"), @{$mod}; + + require GT::SQL::Condition; + my $results = $DB->table('MailingIndex')->select(['mli_id', 'mli_subject'], GT::SQL::Condition->new(mli_id => 'IN' => \@ids))->fetchall_hashref; + return mli_home('0 mailing was scheduled') unless $results; + + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_SCHEDULE_MSG'), selected_mailings => $results }) unless $IN->param('bschedule'); + + my $scm_type = $IN->param('scm_type'); + my $minute = $IN->param('scm_minute') || 0; + my $hour = $IN->param('scm_hour') || 0; + my $text_url = $IN->param('scm_text_url') || ''; + my $html_url = $IN->param('scm_html_url') || ''; + my $option = ''; + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_SCHEDULE_MISSING_TYPE'), selected_mailings => $results }) unless $scm_type; + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_INVALID_URL'), selected_mailings => $results }) if ($text_url and $text_url !~ /^http/); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_INVALID_URL'), selected_mailings => $results }) if ($html_url and $html_url !~ /^http/); + + if ($scm_type == 1) { + my $opt_date = $IN->param('opt_date'); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), selected_mailings => $results }) unless $opt_date; + + my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%'; + my $valid = GList::date_to_time($opt_date, $format); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')), selected_mailings => $results }) unless $valid; + + $option = $valid; + } + elsif ($scm_type == 3) { + my $opt_weekly = $IN->param('opt_weekly'); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), selected_mailings => $results }) unless $opt_weekly; + $option = $opt_weekly; + } + elsif ($scm_type == 4) { + my $opt_monthly = $IN->param('opt_monthly'); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), selected_mailings => $results }) unless $opt_monthly; + $option = $opt_monthly; + } + + my @scheduleds; + my $db = $DB->table('ScheduledMailings'); + foreach my $m (@$results) { + $db->insert({ scm_mailing_id_fk => $m->{mli_id}, scm_hour => $hour, scm_minute => $minute, scm_type => $scm_type, scm_option => $option, scm_text_url => $text_url, scm_html_url => $html_url }) or next; + push @scheduleds, $m->{mli_id}; + } + $DB->table('MailingIndex')->update({ mli_done => 0, mli_scheduled => 1}, GT::SQL::Condition->new( mli_id => 'IN' => \@scheduleds )); + mli_home(GList::language('MLI_SCHEDULES_CREATED', $#scheduleds + 1)); +} +END_OF_SUB + +$COMPILE{mli_schedule_modify} = __LINE__ . <<'END_OF_SUB'; +sub mli_schedule_modify { +#-------------------------------------------------------------------- +# + my $msg = ''; + my $mli_id = $IN->param('mli_id'); + my $cgi = $IN->get_hash(); + delete $cgi->{mli_id}; + + return mli_home(GList::language('MLI_MISSING_ID')) unless $mli_id; + return mli_home($msg, $cgi) if $IN->param('bcancel'); + + my $schedule = $DB->table('ScheduledMailings', 'MailingIndex')->select(['ScheduledMailings.*', 'MailingIndex.mli_subject'], { scm_mailing_id_fk => $mli_id })->fetchrow_hashref; + return mli_home("$mli_id not found!") unless $schedule; + + if ($IN->param('mod_action') and $IN->param('mod_action') eq 'delete') { + return mli_schedule_delete($mli_id); + } + elsif ($IN->param('bmodify')) { + my $scm_type = $IN->param('scm_type'); + my $minute = $IN->param('scm_minute') || 0; + my $hour = $IN->param('scm_hour') || 0; + my $text_url = $IN->param('scm_text_url') || ''; + my $html_url = $IN->param('scm_html_url') || ''; + my $option = ''; + + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_INVALID_URL'), %$schedule }) if ($text_url and $text_url !~ /^http/); + return mli_print('mli_schedule_mailing.html', { msg => GList::language('MLI_INVALID_URL'), %$schedule }) if ($html_url and $html_url !~ /^http/); + + if ($scm_type == 1) { + my $opt_date = $IN->param('opt_date'); + return mli_print('mli_modify_schedule.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), scm_type => 1, %$schedule }) unless $opt_date; + + my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%'; + my $valid = GList::date_to_time($opt_date, $format); + return mli_print('mli_modify_schedule.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')), %$schedule }) unless $valid; + + $option = $valid; + } + elsif ($scm_type == 3) { + my $opt_weekly = $IN->param('opt_weekly'); + return mli_print('mli_modify_schedule.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), scm_type => 3, %$schedule }) unless $opt_weekly; + $option = $opt_weekly; + } + elsif ($scm_type == 4) { + my $opt_monthly = $IN->param('opt_monthly'); + return mli_print('mli_modify_schedule.html', { msg => GList::language('MLI_SCHEDULE_MISSING_OPT'), scm_type => 4, %$schedule }) unless $opt_monthly; + $option = $opt_monthly; + } + $DB->table('ScheduledMailings')->update({ scm_hour => $hour, scm_minute => $minute, scm_type => $scm_type, scm_inprocess => 0, scm_sent => 0, scm_option => $option, scm_text_url => $text_url, scm_html_url => $html_url }, { scm_mailing_id_fk => $mli_id }); + return mli_home(GList::language('MLI_SCHEDULE_UPDATED', $mli_id), $cgi); + } + + my ($opt_monthly, $opt_weekly, $opt_date); + if ($schedule->{scm_type} == 1) { + require GT::Date; + my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%'; + $opt_date = GT::Date::date_get($schedule->{scm_option}, $format); + } + elsif ($schedule->{scm_type} == 3) { + $opt_weekly = $schedule->{scm_option}; + } + elsif ($schedule->{scm_type} == 4) { + $opt_monthly = $schedule->{scm_option}; + } + return mli_print('mli_modify_schedule.html', { msg => $msg, opt_date => $opt_date, opt_weekly => $opt_weekly, opt_monthly => $opt_monthly, %$schedule }); +} +END_OF_SUB + +$COMPILE{mli_schedule_delete} = __LINE__ . <<'END_OF_SUB'; +sub mli_schedule_delete { +#-------------------------------------------------------------------- +# + my $mli_id = shift; + + my @ids; + my $cgi = $IN->get_hash(); + delete $cgi->{mli_id}; + if ($mli_id) { + push @ids, $mli_id; + } + else { + my $mod = ref $IN->param('modify') eq 'ARRAY' ? $IN->param('modify') : [$IN->param('modify')]; + @ids = map $IN->param("$_-mli_id"), @{$mod}; + } + foreach my $id (@ids) { + $DB->table('ScheduledMailings')->delete({ scm_mailing_id_fk => $id }); + $DB->table('MailingIndex')->update({ mli_scheduled => 0 }, { mli_id => $id }); + } + my $msg = $mli_id ? GList::language('MLI_SCHEDULE_DELETED', $mli_id) : GList::language('MLI_SCHEDULES_DELETED', $#ids + 1); + return mli_home($msg, $cgi); +} +END_OF_SUB + +$COMPILE{_print_results} = __LINE__ . <<'END_OF_SUB'; +sub _print_results { + my ($call_from, $checkeds, $bounceds, $deleteds) = @_; + if ($call_from eq 'web') { + mli_bounced_form(undef, 'mli_check_bounced_results.html'); + } + else { + print qq!\n + - Total checked email(s): $checkeds + - Total bounced email(s): $bounceds + - Total deleted email(s): $deleteds +!; + } +} +END_OF_SUB + +$COMPILE{_bounced} = __LINE__ . <<'END_OF_SUB'; +sub _bounced { +#------------------------------------------------------------------- +# + my ($call_from, $connection, $opts) = @_; + + require GT::Mail::POP3; + my $pop = new GT::Mail::POP3 ($connection); + my $num_emails = $pop->connect; + if ($GT::Mail::POP3::error) { + ($call_from eq 'web') ? return mli_bounced_form("$GT::Mail::POP3::error") + : die "$GT::Mail::POP3::error"; + } + if ($call_from eq 'web' and $opts->{save}) { # Save connection to users' profile + $DB->table('Users')->update({ + usr_mail_host => $connection->{host}, + usr_mail_port => $connection->{port} || 110, + usr_mail_account => $connection->{user}, + usr_mail_password => $connection->{pass}, + }, { usr_username => $USER->{usr_username} } + ); + } + if ($num_emails == 0) { + $pop->quit; + return _print_results($call_from, 0, 0); + } + elsif ($call_from eq 'web' and $num_emails > $CFG->{max_bounced_emails}) { + $pop->quit; + return mli_bounced_form(GList::language('MLI_OVERLIMIT_BOUNCEDS')); + } + + my $db_sub = $DB->table('Subscribers'); + my $db_eml = $DB->table('EmailMailings'); + +# handle the progress bar + my ($last_width, $checked, $bounced, $deleted) = (0, 0, 0, 0); + my ($prog_header, $prog_footer) = ''; + my $max_width = ($call_from eq 'web') ? 420 : 50; + if ($call_from eq 'web') { + GList::display('mli_progress_bar.html'); + $prog_header = ""; + } + else { + $prog_header = ""; + $prog_footer = "Done"; + } + + print $prog_header; + foreach ( 1..$num_emails ) { + $checked++; + my $content = $pop->retr($_); + if ($$content =~ /x-glist:\s+(\w+)/i) { + my $code = $1; + my $info = $db_eml->get({ eml_code => $code }); + if ($info) { + $db_sub->update({ sub_bounced => \'sub_bounced + 1' }, { sub_email => $info->{eml_email} }); + $db_eml->update({ eml_bounced => 1 }, { eml_email => $info->{eml_email}, eml_code => $code }); + $bounced++; + if ($opts->{delete} =~ /1|2/) { + if ($pop->dele($_)) { + $deleted++; + } + else { + warn "Can't delete email $_: $GT::Mail::POP3::error"; + } + } + } + } + elsif ($opts->{delete} == 2) { # delete all option is set. + if ($pop->dele($_)) { + $deleted++; + } + else { + warn "Can't delete email $_: $GT::Mail::POP3::error"; + } + } + my $wpercent = 1 - ($num_emails - $checked) / $num_emails; + my $img_width= int($max_width * $wpercent); + if ($img_width != $last_width) { + if ($call_from eq 'web') { + printf "\n", 100 * $wpercent; + } + else { + _print_dot($img_width - $last_width); + } + $last_width = $img_width; + } + } + $pop->quit; + + if ($call_from eq 'web') { + my $url = ($USER->{use_cookie}) ? "$CFG->{cgi_url}/glist.cgi?do=mli_bounced_form;parsed=$num_emails;bounced=$bounced;deleted=$deleted;results=1" + : "$CFG->{cgi_url}/glist.cgi?do=mli_bounced_form;parsed=$num_emails;bounced=$bounced;deleted=$deleted;results=1;sid=$USER->{session_id}"; + print ""; + } + else { + print $prog_footer; + _print_results($call_from, $num_emails, $bounced, $deleted); + } +} +END_OF_SUB + +$COMPILE{_send} = __LINE__ . <<'END_OF_SUB'; +sub _send { +#--------------------------------------------------------------------- +# This subsroutine will be called from either web or shell mode +# + my ($call_from, $ids, $total_size) = @_; + + require GList::Template; + require GT::TempFile; + + my $demo = 0; +#------------demo code----------- + + if ($call_from eq 'web') { + GList::display('mli_progress_bar.html'); + print ""; + } + + my $start = time(); + my $started = scalar localtime; + my $db_mli = $DB->table('MailingIndex'); + my $db_eml = $DB->table('EmailMailings'); + my $db_mat = $DB->table('MailingAttachments'); + my $db_sub = $DB->table('Subscribers'); + my $db_usr = $DB->table('Users'); + my $sub_cols = $DB->table('Subscribers')->cols; + my $usr_cols = $DB->table('Users')->cols; + my $num_sent = ($call_from eq 'web') ? (GList::check_limit('email30') || 0) : 0; + my $data = $USER || {}; + $data->{cgi_url} = $CFG->{cgi_url}; + $data->{image_url} = $CFG->{image_url}; + + +# Load StopLists + my $stoplist = $DB->table('StopLists')->select(['stl_email'])->fetchall_arrayref; + my %stoplist; + foreach (@$stoplist) { + next if (!$_->[0]); + exists $stoplist{$_->[0]} or $stoplist{$_->[0]} = 1; + } + + $|++; + my ($count, $sent_size, $last_width) = (0, 0, -1); + my ($html_header, $html_footer, $text_header, $text_footer, $prog_header, $prog_footer); + my $max_width = ($call_from eq 'web') ? 420 : 50; + my $temp_text = new GT::TempFile; + my $temp_html = new GT::TempFile; + if ($call_from eq 'web') { + $prog_header = ""; + my $url = ($USER->{use_cookie}) ? "$CFG->{cgi_url}/glist.cgi?do=mli_home;fd=2;sent=$count;demo=$demo" + : "$CFG->{cgi_url}/glist.cgi?do=mli_home;fd=2;sent=$count;sid=$USER->{session_id};demo=$demo"; + $prog_footer = ""; + +# Set header and footer if they are specified + $html_header = ($CFG->{header_html}) ? "$CFG->{header_html}
      $USER->{usr_header_html}" : $USER->{usr_header_html}; + $html_footer = ($CFG->{footer_html}) ? "$USER->{usr_footer_html}
      $CFG->{footer_html}" : $USER->{usr_footer_html}; + $text_header = ($CFG->{header_text}) ? "$CFG->{header_text}\n$USER->{usr_header_text}" : $USER->{usr_header_text}; + $text_footer = ($CFG->{footer_text}) ? "$USER->{usr_footer_text}\n$CFG->{footer_text}" : $USER->{usr_footer_text}; + } + else { + $prog_header = "\nSending messages\n"; + $prog_footer = "Done\n"; + } + + print $prog_header; + foreach my $mailing (@$ids) { + my ($msg_size, $att_size, $info) = (0, 0, {}); + + if ($call_from eq 'web') { + last if ($USER->{usr_type} == LIMITED_USER and $num_sent >= $USER->{usr_limit_email30}); + $info = GList::check_owner('MailingIndex', 'mli', $mailing); + } + else { + $info = $db_mli->get($mailing); + my $user = $db_usr->get({ usr_username => $info->{mli_user_id_fk}}); + if ($user) { + $data = $user; + $html_header = ($CFG->{header_html}) ? "$CFG->{header_html}
      $user->{usr_header_html}" : $user->{usr_header_html}; + $html_footer = ($CFG->{footer_html}) ? "$user->{usr_footer_html}
      $CFG->{footer_html}" : $user->{usr_footer_html}; + $text_header = ($CFG->{header_text}) ? "$CFG->{header_text}\n$user->{usr_header_text}" : $user->{usr_header_text}; + $text_footer = ($CFG->{footer_text}) ? "$user->{usr_footer_text}\n$CFG->{footer_text}" : $user->{usr_footer_text}; + } + } + next if (!$info or ref $info ne 'HASH'); + next if ($info->{mli_done}); # Skip if it has already been sent + + $count++; + my $mailings = $db_eml->select({ eml_mailing_id_fk => $mailing, eml_sent => 0 })->fetchall_hashref; + my $attachs = $db_mat->select({ mat_mailing_id_fk => $mailing })->fetchall_hashref; + +# Figure out the attachments size + foreach (@$attachs) { + $att_size += -s "$CFG->{priv_path}/attachments/mailings/" . ($mailing % 10) . "/$mailing/$_->{mat_id}"; + } + +# Figure out the message size + my $content_text = $info->{mli_message_text}; + my $content_html = $info->{mli_message_html}; + $msg_size = length $content_html if ($content_html); + $msg_size += length $content_text if ($content_text); + +# Add header and footer if they are available + $content_text = "$text_header\n$content_text" if ($content_text and $text_header); + $content_text .= "\n$text_footer" if ($content_text and $text_footer); + $content_html = "$html_header
      $content_html" if ($content_html and $html_header); + $content_html .= "
      $html_footer" if ($content_html and $html_footer); + + open (TEXT, "> $$temp_text"); + print TEXT $content_text; + close TEXT; + + if ($info->{mli_message_html}) { + $content_html =~ s/<%/<%/g; + $content_html =~ s/%>/%>/g; + if ($info->{mli_track_open}) { # Insert track openning code + $content_html.= ($CFG->{iframe_tracking}) ? TRACK_OPEN_HTML : TRACK_OPEN_HTML_NOIFRAME; + } + $content_html = _replace_url($content_html, TRACK_CLICK_URL) if ($info->{mli_track_click}); + open (HTML, "> $$temp_html"); + print HTML $content_html; + close HTML; + } + foreach my $m (@$mailings) { + last if ($call_from eq 'web' and $USER->{usr_type} == LIMITED_USER and $num_sent >= $USER->{usr_limit_email30}); + next unless $db_eml->count( eml_id => $m->{eml_id}, eml_sent => '0' ); + + if ( exists $stoplist{$m->{eml_email}} ) { # skip email if it's in stoplist + $db_eml->update({ eml_skipped => '1', eml_sent => time }, { eml_id => $m->{eml_id} }); + next; + } + + my $bounce_code = _generate_bounce_code(); + my $sth = $db_eml->update({ eml_sent => time, eml_code => $bounce_code }, { eml_id => $m->{eml_id}, eml_sent => 0 }) + or next; + my $rows = $sth->rows; + next unless $rows; + +# Allows personalizing of messages using <%...%> tags + my $lists = join ';', map "lid=$_", split ',', $m->{eml_lists}; + $data->{mailing} = $info->{mli_id}; + $data->{eml_code}= $bounce_code; + $data->{unsubscribe_url} = ($info->{mli_track_click}) ? "$CFG->{cgi_url}/glist.cgi?do=user_click;mailing=$info->{mli_id};url=".$IN->escape("$CFG->{cgi_url}/glist.cgi?do=user_rm;eml_code=$bounce_code;$lists") + : "$CFG->{cgi_url}/glist.cgi?do=user_rm;eml_code=$bounce_code;$lists"; + + #-------------------------- + # LJM: Parse out arbitrary lists - keys will replace these + #-------------------------- + $lists = "lid="; + $data->{unsubscribe_list} = ($info->{mli_track_click}) ? "$CFG->{cgi_url}/glist.cgi?do=user_click;mailing=$info->{mli_id};url=".$IN->escape("$CFG->{cgi_url}/glist.cgi?do=user_rm;eml_code=$bounce_code;$lists") + : "$CFG->{cgi_url}/glist.cgi?do=user_rm;eml_code=$bounce_code;$lists"; + $data->{subscribe_list} = ($info->{mli_track_click}) ? "$CFG->{cgi_url}/glist.cgi?do=user_click;mailing=$info->{mli_id};url=".$IN->escape("$CFG->{cgi_url}/glist.cgi?do=user_subscribe;eml_code=$bounce_code;$lists") + : "$CFG->{cgi_url}/glist.cgi?do=user_subscribe;eml_code=$bounce_code;$lists"; + $lists = "from_to_lid="; + $data->{move_list} = ($info->{mli_track_click}) ? "$CFG->{cgi_url}/glist.cgi?do=user_click;mailing=$info->{mli_id};url=".$IN->escape("$CFG->{cgi_url}/glist.cgi?do=user_move;eml_code=$bounce_code;$lists") + : "$CFG->{cgi_url}/glist.cgi?do=user_move;eml_code=$bounce_code;$lists"; + #-------------------------- + + foreach ( keys %$sub_cols ) { # Subscriber's information + (my $c = $_) =~ s/sub/eml/; + $data->{$_} = $m->{$c}; + } + + my $text = $content_text; + my $html = $content_html; + my $key = join '|', map quotemeta, keys %$data; + + $text =~ s/<%($key)%>/$data->{$1}/g; + $html =~ s/<%($key)%>/$data->{$1}/g; + + $text = GList::Template->parse($$temp_text, $data, { disable => { functions => 1 } }) if ($text =~ /<%/); + $html = GList::Template->parse($$temp_html, $data, { disable => { functions => 1 } }) if ($html and $html =~ /<%/); + + my %head; + my $to_quoted = "$m->{eml_name} "; + my $from_quoted = "$info->{mli_name} "; + if ($to_quoted =~ /[^\w\s]/) { + $to_quoted =~ s/([\\"])/\\$1/g; + $to_quoted = '"' . substr($to_quoted, 0, -1) . '" '; + } + if ($from_quoted =~ /[^\w\s]/) { + $from_quoted =~ s/([\\"])/\\$1/g; + $from_quoted = '"' . substr($from_quoted, 0, -1) . '" '; + } + $head{from} = $info->{mli_name} ? $from_quoted . "<$info->{mli_from}>" : $info->{mli_from}; + $head{to} = $m->{eml_name} ? $to_quoted . "<$m->{eml_email}>" : $m->{eml_email}; + $head{subject} = $info->{mli_subject}; + $head{'Reply-To'} = $info->{mli_reply_to}; + $head{'Return-Path'}= $info->{mli_bounce_email}; + $head{'X-GList'} = $bounce_code; + +# Handle the progress bar + $sent_size += $msg_size + $att_size; + my $wpercent = 1 - ($total_size - $sent_size) / $total_size; + my $img_width = int($max_width * $wpercent); + + if (!$demo) { + GList::send(\%head, { text => $text, html => $html }, $attachs, "$CFG->{priv_path}/attachments/mailings/" . ($mailing % 10) . "/$mailing", $info->{mli_charset}); + } + $num_sent++; + + if ( $img_width != $last_width ) { + if ($call_from eq 'web') { + printf "\n", 100 * $wpercent; + } + else { + _print_dot($img_width - $last_width); + } + $last_width = $img_width; + } + } + if (!$db_eml->count({ eml_mailing_id_fk => $mailing, eml_sent => 0 })) { + $db_mli->update({ mli_done => time, mli_cat_id_fk => 0 }, { mli_id => $mailing }); + } + } + print $prog_footer; +} +END_OF_SUB + +$COMPILE{_size_mailings} = __LINE__ . <<'END_OF_SUB'; +sub _size_mailings { +#-------------------------------------------------------------------- +# Get the size of mailings +# + my ($ids, $call_from) = @_; + + my $db_attach = $DB->table('MailingAttachments'); + my $db_email = $DB->table('EmailMailings'); + my $db_mailing= $DB->table('MailingIndex'); + my $size = 0; + foreach my $mailing ( @$ids ) { + my $length = 0; + my $info; + +# Check who owns it + if ($call_from eq 'web') { + $info = GList::check_owner('MailingIndex', 'mli', $mailing); + next if (ref $info ne 'HASH'); + } + else { + $info = $db_mailing->get($mailing); + next if (!$info); + } + +# Skip if it's been completed + next if ( $info->{mli_done} ); + +# Of Text and HTML message + $length += length $info->{mli_message_text} if ($info->{mli_message_text}); + $length += length $info->{mli_message_html} if ($info->{mli_message_html}); + +# Get the size of attachments + my $attach = $db_attach->select({ mat_mailing_id_fk => $mailing }); + + while ( my $rs = $attach->fetchrow_hashref ) { + $length += -s "$CFG->{priv_path}/attachments/mailings/" . ($mailing % 10) . "/$mailing/$rs->{mat_id}"; + } + + my $emails = $db_email->count({ eml_mailing_id_fk => $mailing, eml_sent => '0' }); + $length *= $emails if ( $emails ); + $size += $length; + } + return $size; +} +END_OF_SUB + +$COMPILE{_load_navigator} = __LINE__ . <<'END_OF_SUB'; +sub _load_navigator { +#--------------------------------------------------------------------- +# Generates Category listings +# + my $user = GList::load_condition(); + + my $db = $DB->table('CatMailing', 'MailingIndex'); + my $cond = GT::SQL::Condition->new('cm_user_id_fk', $user->{opt}, $user->{id}); + $db->select_options('GROUP BY cm_type,cm_id, cm_name ORDER BY cm_name'); + + my $sth = $db->select('left_join', $cond, ['CatMailing.cm_id', 'CatMailing.cm_type', 'CatMailing.cm_name', 'count(mli_id) as mailing']) or die "$GT::SQL::error"; + my ($draft, $sent); + while ( my $rs = $sth->fetchrow_hashref ) { + if ( $rs->{cm_type} eq '1' ) { + push @$draft, $rs; + } + else { + push @$sent, $rs; + } + } + + my $db_mli = $DB->table('MailingIndex'); + my $cd = GT::SQL::Condition->new( + mli_user_id_fk => $user->{opt} => $user->{id}, + mli_delete => '=' => 0, + mli_done => '=' => 0, + mli_scheduled => '=' => 0, + mli_cat_id_fk => '=' => 0, + ); + my $drafts = $db_mli->select($cd)->rows; + my $scheduled = $db_mli->select({ mli_scheduled => 1, mli_delete => 0 })->rows; + + return { results_draft => $draft, results_sent => $sent, scheduled_hits => $scheduled, + hits_draft => $#$draft + 1, hits_sent => $#$sent + 1, drafts => $drafts, + }; +} +END_OF_SUB + +$COMPILE{_generate_bounce_code} = __LINE__ . <<'END_OF_SUB'; +sub _generate_bounce_code { +# ------------------------------------------------------------------- + my $code; + my $i; + while ($i++ < 10) { + $code = ''; + my @chars = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); + for (1 .. 20) { + $code .= $chars[rand @chars]; + } + last unless ($DB->table('EmailMailings')->count( { eml_code => $code } )); + } + return $code; +} +END_OF_SUB + +$COMPILE{_print_dot} = __LINE__ . <<'END_OF_SUB'; +sub _print_dot { + my $num = shift; + foreach my $i(1..$num) { + print "."; + } +} +END_OF_SUB + +$COMPILE{_replace_url} = __LINE__ . <<'END_OF_SUB'; +sub _replace_url { + my ($content, $url) = @_; + $url ||= ''; + $content =~ s/href\s*=\s*(["'])\s*((?:https?|ftp):\/\/.*?)\1/my $link = $IN->escape($IN->html_unescape($2)); "href=$1$url;url=$link$1"/gise; + return $content; +} +END_OF_SUB + +$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB'; +sub _determine_action { +#---------------------------------------------------------------------------- +# Check valid action +# + my $action = shift || undef; + return if ( !$action ); + return 'mli_home' if ( $action eq 'mli_search' ); + + my %valid = ( + map { $_ => 1 } qw( + mli_home + mli_search_form + mli_empty + mli_delete + mli_move + mli_schedule + mli_schedule_modify + mli_schedule_delete + mli_send + mli_fview + mli_fdownload + mli_bounced_form + mli_bounced + mli_recipients + mli_cat_add + mli_cat_modify + mli_cat_delete + ) + ); + exists $valid{$action} and return $action; + return; +} +END_OF_SUB +1; diff --git a/site/glist/lib/GList/Message.pm b/site/glist/lib/GList/Message.pm new file mode 100644 index 0000000..a4ab26f --- /dev/null +++ b/site/glist/lib/GList/Message.pm @@ -0,0 +1,1185 @@ +# ================================================================== +# Gossamer List - enhanced mailing list management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : +# Revision : $Id: Message.pm,v 1.63 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::Message; +# ====================================================================== +# The file will handle to add/update/delete the messages +# +use strict; +use GList qw/:objects :user_type/; +use GT::AutoLoader; + +sub process { +#------------------------------------------------------------------- +# + my $do = shift; + + $MN_SELECTED = 1; + 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(['msg_cat_id_fk']); + $results->{hidden_query} = $hidden->{hidden_query}; + $results->{hidden_objects} = $hidden->{hidden_objects}; + GList::display($tpl, $results); + } +} + +$COMPILE{msg_spellcheck} = __LINE__ . <<'END_OF_SUB'; +sub msg_spellcheck { +#-------------------------------------------------------------------- +# + return ('spellcheck_inline.html') if $IN->param('load'); + my $results = _spellcheck($IN->param('content'), $IN->param('compose_is_html')); + my $emode = $IN->param('emode'); + if ($emode eq 'multi') { + my $results2 = _spellcheck($IN->param('content2'), 0); + $results->{text_words} = $results2->{words}; + $results->{text_misspellings} = $results2->{misspellings}; + } + return ('spellcheck_inline.html', { emode => $emode, %$results }); +} +END_OF_SUB + +$COMPILE{msg_addword} = __LINE__ . <<'END_OF_SUB'; +sub msg_addword { +#-------------------------------------------------------------------- +# + my $new_word = $IN->param('content'); + return ('spellcheck_inline.html', { error => "Invalid word '$new_word'" }) unless $new_word =~ /^[a-zA-Z']+$/; + + chomp $new_word; # Don't let there be a trailing \n! + my $db = $DB->table('CustomDict') or return ('spellcheck_inline.html', { error => $GT::SQL::error }); + if (my $words = $db->select(custom_words => { username_fk => $USER->{usr_username} })->fetchrow) { + $words .= "\n$new_word"; + $db->update({ custom_words => lc $words }, { username_fk => $USER->{usr_username} }) or return ('spellcheck_inline.html', { error => $GT::SQL::error });; + } + else { + $db->insert({ username_fk => $USER->{usr_username}, custom_words => $new_word }) or return ('spellcheck_inline.html', { error => $GT::SQL::error }); + } + return ('spellcheck_inline.html', { word => $new_word }); +} +END_OF_SUB + +$COMPILE{msg_page} = <<'END_OF_SUB'; +sub msg_page { +#-------------------------------------------------------------------- +# + my $page = shift || $IN->param('pg'); + return ($page); +} +END_OF_SUB + +$COMPILE{msg_home} = <<'END_OF_SUB'; +sub msg_home { +#-------------------------------------------------------------------- +# Print home page +# + my $msg = shift; + + my $cgi = $IN->get_hash; + if ( defined $cgi->{do} and $cgi->{do} =~ /msg_add|msg_modify|msg_delete/ ) { + foreach (keys % {$DB->table('Messages')->cols}) { + $cgi->{$_} = '' if $_ ne 'msg_cat_id_fk'; + } + } + elsif (!$cgi->{msg_cat_id_fk} and $cgi->{do} !~ /msg_search/) { # Display message in home directory + $cgi->{msg_cat_id_fk} = 0; + } + + my $query = ''; + my $search_check = ($IN->param('do') eq 'msg_search') ? 1 : 0; + if ($cgi->{'msg_created-ge'} or $cgi->{'msg_created-le'}) { + my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%'; + my ($valid_from, $valid_to) = (1, 1); + + require GT::Date; + if ($cgi->{'msg_created-ge'}) { + $query = "msg_created-ge=$cgi->{'msg_created-ge'};"; + $valid_from = GList::date_to_time($cgi->{'msg_created-ge'}, $format); + $cgi->{'msg_created-ge'} = GT::Date::date_get($valid_from, $format) if ($valid_from); + } + if ($cgi->{'msg_created-le'}) { + $query = "msg_created-le=$cgi->{'msg_created-le'}"; + $valid_to = GList::date_to_time($cgi->{'msg_created-le'}, $format); + $cgi->{'msg_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 msg_search_form(GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT'))); + } + } + my $results = GList::search( + cgi => $cgi, + db => $DB->table('Messages'), + prefix => 'msg', + sb => 'msg_created', + so => 'DESC', + search_check=> $search_check + ); + my $nav = _load_navigator() || {}; + + if ( ref $results ne 'HASH' ) { + ( $IN->param('do') eq 'msg_search' ) ? return ('msg_search_form.html', { msg => $msg || $results, %$nav}) + : return ('msg_home.html', { msg => $msg || $results, %$nav }); + } + elsif ( $results->{error} and $search_check ) { + return msg_search_form($results->{error}); + } + if ($msg) { + $results->{msg} = $msg; + } + elsif ($cgi->{p}) { + $results->{msg} = ''; + } + + return ('msg_home.html', { %$results, %$nav, toolbar_query => $query }); +} +END_OF_SUB + +$COMPILE{msg_add_form} = <<'END_OF_SUB'; +sub msg_add_form { +#-------------------------------------------------------------------- +# Print Add Form +# + my $msg = shift; + + my $attachments = _get_attachments(); + my $navigator = _load_navigator() || {}; + my $contents = _switch_editor_mode(); + my $emode = $IN->param('emode') || $USER->{usr_compose_mode} || 'text'; + my $editor_advanced; + if (!defined $IN->param('editor_advanced') and $USER->{usr_editor_advanced}) { + $editor_advanced = 1; + } + return ('msg_add_form.html', { + msg => $msg, + attachments => $attachments, + hits => $#$attachments + 1, + emode => $emode, + help => 'message_add.html', %$navigator, %$contents, + editor_advanced => $editor_advanced + }); +} +END_OF_SUB + +$COMPILE{msg_add} = <<'END_OF_SUB'; +sub msg_add { +#-------------------------------------------------------------------- +# + + my $attachments; + if ($IN->param('add_attach')) { # add an attachment + $attachments = _add_attach(); + return msg_add_form($attachments) if (ref $attachments ne 'ARRAY'); + return ('msg_add_form.html', { attachments => $attachments, hits => $#$attachments + 1 }); + } + + if ($IN->param('del_attach')) { # Delete an attachment + $attachments = _del_attach(); + return msg_add_form($attachments) if (ref $attachments ne 'ARRAY'); + return ('msg_add_form.html', { attachments => $attachments, hits => $#$attachments + 1 }); + } + + $attachments = _get_attachments(); + if ($IN->param('bswitch') or $IN->param('switch_editor')) { + return msg_add_form(); + } + + if ($attachments and _size_attachments() > $CFG->{max_attachments_size}) { + return msg_add_form(GList::language('MSG_OUTOF_LIMIT')); + } + +# Add message into database + my $content_html = $IN->param('msg_content_html'); + my $content_text = $IN->param('msg_content_text'); + if ($content_html =~ /^\s*\s*\s*<\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*\s*<\/body>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*

      \ <\/p><\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*

      \ <\/P><\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*
      \s*<\/html>\s*$/i) { + $content_html = ""; + } + if (!$content_html and !$content_text) { + return msg_add_form(GList::language('MSG_EMPTY')); + } + + my $cgi = $IN->get_hash(); + if ($IN->param('msg_mode') =~ /html|multi/ and $content_html) { + $cgi->{msg_content_text} = _convert_to_text($content_html) if ($IN->param('msg_mode') eq 'html'); + $cgi->{msg_track_open} = ($cgi->{msg_track_open}) ? 1 : 0; + $cgi->{msg_track_click} = ($cgi->{msg_track_click}) ? 1 : 0; + } + else { + $cgi->{msg_track_open} = 0; + $cgi->{msg_track_click}= 0; + } + +# Add message into database + my $ret = GList::add('Messages', 'msg', $cgi); + return msg_add_form("$GList::error") if ( $GList::error ); + +# Add attachments + if ($attachments) { + my $db = $DB->table('MessageAttachments'); + my $path = "$CFG->{priv_path}/attachments/messages/" . ($ret % 10) . "/$ret"; + + mkdir($path, 0777) or return msg_home(GList::language('MSG_MKDIR_ERR', $!)); + + require GT::File::Tools; + foreach ( @$attachments ) { + my $attach_id = $db->add({ + att_message_id_fk => $ret, + att_file_name => $_->{user_fname}, + att_file_size => $_->{fsize} + }) or die $GT::SQL::error; + GT::File::Tools::move("$CFG->{priv_path}/tmp/$_->{fname}", "$path/$attach_id") or return msg_home(GList::language('MSG_ATTACH_ADD', $!)); + } + } + return msg_home(GList::language('MSG_ADD_SUCCESS', $IN->param('msg_subject') || $ret)) if ($ret); +} +END_OF_SUB + +$COMPILE{msg_modify_form} = <<'END_OF_SUB'; +sub msg_modify_form { +#-------------------------------------------------------------------- +# Print modify form +# + my $msg = shift; + + my $id = $IN->param('msg_id'); + return msg_home(GList::language('MSG_INVALID')) if (!$id or ref $id eq 'ARRAY'); + + my $info = GList::check_owner('Messages', 'msg', $id); + return msg_home($info) if (ref $info ne 'HASH'); + + my $navigator = _load_navigator() || {}; + my $editor_advanced; + if (!defined $IN->param('editor_advanced') and $USER->{usr_editor_advanced}) { + $editor_advanced = 1; + } + if ($IN->param('do') eq 'msg_modify_form') { + my $attachments = _load_attachments($info->{msg_id}); + $info->{msg_content_html} = $IN->html_escape($info->{msg_content_html}); + return ('msg_modify_form.html', { + msg => $msg, %$info, %$navigator, + attachments => $attachments, + editor_advanced => $editor_advanced, + hits => $#$attachments + 1, + help => 'message_add.html', + emode => $info->{msg_mode} + }); + } + else { + my $attachments = _get_attachments(); + my $contents = _switch_editor_mode(); + return ('msg_modify_form.html', { + msg => $msg, + attachments => $attachments, + editor_advanced => $editor_advanced, + hits => $#$attachments + 1, + help => 'message_add.html', %$navigator, %$contents + }); + } +} +END_OF_SUB + +$COMPILE{msg_modify} = <<'END_OF_SUB'; +sub msg_modify { +#-------------------------------------------------------------------- +# Modify a message +# + my $attachments; + if ($IN->param('bcancel')) { # Cancel to edit a record + $attachments = _get_attachments(); + foreach (@$attachments) { + unlink "$CFG->{priv_path}/tmp/$_->{fname}"; + } + return msg_home(); + } + + if ($IN->param('add_attach')) { # add an attachment + $attachments = _add_attach(); + return msg_modify_form($attachments) if (ref $attachments ne 'ARRAY'); + return ('msg_modify_form.html', { attachments => $attachments, hits => $#$attachments + 1 }); + } + + if ($IN->param('del_attach')) { # Delete an attachment + $attachments = _del_attach(); + return msg_modify_form($attachments) if (ref $attachments ne 'ARRAY'); + return ('msg_modify_form.html', { attachments => $attachments, hits => $#$attachments + 1 }); + } + +# Handle the attachments + $attachments = _get_attachments(); + + if ($IN->param('bswitch') or $IN->param('switch_editor')) { + return msg_modify_form(); + } + my $content_html = $IN->param('msg_content_html'); + my $content_text = $IN->param('msg_content_text'); + if ($content_html =~ /^\s*\s*\s*<\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*\s*<\/body>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*

      \ <\/p><\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*

      \ <\/P><\/BODY>\s*<\/html>\s*$/i or + $content_html =~ /^\s*\s*
      \s*<\/html>\s*$/i) { + $content_html = ""; + } + if (!$content_html and !$content_text) { + return msg_modify_form(GList::language('MSG_EMPTY')); + } + + my $cgi = $IN->get_hash(); + if ($IN->param('msg_mode') =~ /html|multi/ and $content_html) { + $cgi->{msg_content_text} = _convert_to_text($content_html) if ($IN->param('msg_mode') eq 'html'); + $cgi->{msg_track_open} = ($cgi->{msg_track_open}) ? 1 : 0; + $cgi->{msg_track_click} = ($cgi->{msg_track_click}) ? 1 : 0; + } + else { + $cgi->{msg_track_open} = 0; + $cgi->{msg_track_click}= 0; + } + +# Update a message + GList::modify('Messages', 'msg', $cgi); + return msg_modify_form($GList::error) if ($GList::error); + + my $id = $IN->param('msg_id'); + my $db = $DB->table('MessageAttachments'); + my $sth = $db->select({ att_message_id_fk => $id }, ['att_id']); + my $path = "$CFG->{priv_path}/attachments/messages/" . ($id % 10) . "/$id"; + + while ( my $att = $sth->fetchrow_array ) { + unlink "$path/$att"; + } + $db->delete({ att_message_id_fk => $id }); + +# Create a directory if it does not exist + require GT::File::Tools; + if ($#$attachments >= 0) { + if ( ! -e $path ) { + mkdir ($path, 0777) or return msg_home(GList::language('MSG_MKDIR_ERR', $!)); + } + + foreach ( @$attachments ) { + my $attach_id = $db->add({ + att_message_id_fk => $id, + att_file_name => $_->{user_fname}, + att_file_size => $_->{fsize} + }); + + GT::File::Tools::move("$CFG->{priv_path}/tmp/$_->{fname}", "$path/$attach_id") or return msg_home(GList::language('MSG_ATTACH_ADD', $!)); + } + } + elsif (-e $path) { + GT::File::Tools::deldir($path); + } + + msg_home(GList::language('MSG_MOD_SUCCESS', $IN->param('msg_subject') || $id)); +} +END_OF_SUB + +$COMPILE{msg_search_form} = <<'END_OF_SUB'; +sub msg_search_form { +#------------------------------------------------------------------- +# Print search form +# + my $msg = shift; + + my $db = $DB->table('CatMessages'); + my $sth = $db->select({ cms_user_id_fk => $USER->{usr_username} }); + my $output; + while ( my $rs = $sth->fetchrow_hashref ) { + push @$output, $rs; + } + + my $navigator = _load_navigator() || {}; + return ('msg_search_form.html', { msg => $msg, results => $output, hits => $#$output + 1, %$navigator }); +} +END_OF_SUB + +$COMPILE{msg_send_sample} = <<'END_OF_SUB'; +sub msg_send_sample { +#-------------------------------------------------------------------- +# Send a copy to an email address +# + my $msg_id = $IN->param('msg_id'); + my $email = $IN->param('email'); + my $name = $IN->param('name') || ''; + +#------------demo code----------- + +# Check record's owner + my $info = GList::check_owner('Messages', 'msg', $msg_id); + return msg_home($info) if (ref $info ne 'HASH'); + + if ( $email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/ ) { # check email address + return msg_home(GList::language('LST_IPT_INVALID_EMAIL')); + } + +# Allows personalizing of messages using <%...%> tags + require GList::Template; + my $hash = $USER; + $hash->{sub_email} = $email; + $hash->{sub_name} = $name; + $info->{msg_content_text} = GList::Template->parse( + "string", + [$hash], + { + string => $info->{msg_content_text}, + disable => { functions => 1 } + } + ) if ( $info->{msg_content_text} ); + + $info->{msg_content_html} = GList::Template->parse( + "string", + [$hash], + { + string => $info->{msg_content_html}, + disable => { functions => 1 } + } + ) if ( $info->{msg_content_html} ); + + my %head; + $head{from} = ( $info->{msg_from_name} ) ? "$info->{msg_from_name} <$info->{msg_from_email}>" : $info->{msg_from_email}; + $head{to} = ( $name ) ? "$name <$email>" : $email; + $head{subject} = $info->{msg_subject}; + $head{'Reply-To'} = $info->{msg_reply_to}; + $head{'Return-Path'}= $info->{msg_bounce_email}; + +# Load attachments + my $attachments = $DB->table('MessageAttachments')->select({ att_message_id_fk => $msg_id })->fetchall_hashref; + GList::send(\%head, { text => $info->{msg_content_text}, html => $info->{msg_content_html} }, $attachments, "$CFG->{priv_path}/attachments/messages/" . ($msg_id % 10) . "/$msg_id", $info->{msg_charset}); + return msg_home(GList::language('MSG_EMAIL_SENT', $email)); +} +END_OF_SUB + +$COMPILE{msg_send_form} = __LINE__ . <<'END_OF_SUB'; +sub msg_send_form { +#-------------------------------------------------------------------- +# Send email - Step 1: select the lists +# + my $msg = shift; + + my @messages; + my $cgi = $IN->get_hash(); + my $query = ''; + if ($cgi->{msg_id}) { + my $ids = (ref $cgi->{msg_id} eq 'ARRAY') ? $cgi->{msg_id} : [$cgi->{msg_id}]; + foreach my $id (@$ids) { + my $info = GList::check_owner('Messages', 'msg', $id); + push @messages, { msg_id => $info->{msg_id}, msg_subject => $info->{msg_subject} } if ( ref $info eq 'HASH' ); + $query .= "msg_id=$info->{msg_id};"; + } + } + else { + my $modify = (ref $cgi->{modify} eq 'ARRAY') ? $cgi->{modify} : [$cgi->{modify}]; + foreach my $i (@$modify) { + my $info = GList::check_owner('Messages', 'msg', $cgi->{"$i-msg_id"}); + push @messages, { msg_id => $info->{msg_id}, msg_subject => $info->{msg_subject} } if ( ref $info eq 'HASH' ); + $query .= "msg_id=$info->{msg_id};"; + } + } + + return msg_home(GList::language('MSG_SEND_INVALID')) if (!@messages); + +# Get the Mailing Lists + my $results = GList::search( + cgi => $cgi, + db => $DB->table('Lists'), + prefix => 'lst', + sb => 'lst_title', + so => 'ASC', + show_user => $cgi->{show_user}, + select_all => $cgi->{mh} == -1 ? 1 : 0 + ); + (ref $results eq 'HASH') or return msg_home(GList::language('MSG_LST_EMPTY')); + $results->{msg} = $msg; + + my $subs = $DB->table('Subscribers'); + my $output = $results->{results}; + foreach my $rs (@$output) { + $rs->{subscribers} = $subs->count({ sub_list_id_fk => $rs->{lst_id} }); + $rs->{val_subs} = $subs->count({ sub_list_id_fk => $rs->{lst_id}, sub_validated => 1 }); + $rs->{bounced_emails} = $subs->count({ sub_list_id_fk => $rs->{lst_id}, sub_Bounced => 1 }); + } + + my $nav = _load_navigator() || {}; + if ($#messages > 0) { + return ('msg_send_form.html', { + toolbar_query => $query, + mul_messages => 1, + loop_messages => \@messages, + help => 'message_send.html', %$results, %$nav + }); + } + else { + my $info = $messages[0] || {}; + return ('msg_send_form.html', { + toolbar_query => $query, + msg_id => $info->{msg_id}, + loop_messages => \@messages, + help => 'message_send.html', %$results, %$nav + }); + } +} +END_OF_SUB + +$COMPILE{msg_send} = __LINE__ . <<'END_OF_SUB'; +sub msg_send { +#-------------------------------------------------------------------- +# Send email - step 2: Preview the content +# + return msg_send_form(GList::language('MSG_MLI_ERR')) unless($IN->param('modify')); + +# Load database objects + my $db_msg = $DB->table('Messages'); + my $db_mli = $DB->table('MailingIndex'); + my $db_eml = $DB->table('EmailMailings'); + my $db_sub = $DB->table('Subscribers'); + my $db_mat = $DB->table('MailingAttachments'); + + my $mod = (ref $IN->param('modify') eq 'ARRAY') ? $IN->param('modify') : [$IN->param('modify')]; + + my (%emails, %lists, @subs, @lists, $sent); + foreach my $row_num (@$mod) { + my $id = $IN->param("$row_num-list_id_fk"); + my $info = GList::check_owner('Lists', 'lst', $id); + next if (!$info); + push @lists, $id; + } + +# If sending to multiple lists, ensure that duplicate address don't occur: + my $substh = $db_sub->select( + 'sub_email', 'sub_name', 'sub_list_id_fk', + { sub_validated => 1, sub_list_id_fk => \@lists } + ); + while (my ($email, $name, $list) = $substh->fetchrow) { + $email = lc $email; + $emails{$email} ||= $name; + $lists{$email} ||= []; + push @{$lists{$email}}, $list; + } + + foreach my $e (keys %emails) { + push @subs, [lc $e, $emails{$e}, join ',', @{$lists{$e}}]; + } + + my $messages = (ref $IN->param('msg_id') eq 'ARRAY') ? $IN->param('msg_id') : [$IN->param('msg_id')]; + foreach my $id (@$messages) { + my $info = GList::check_owner('Messages', 'msg', $id); + next if ( ref $info ne 'HASH' ); + +# Get the attachments + my $attachs = $DB->table('MessageAttachments')->select({ att_message_id_fk => $info->{msg_id} })->fetchall_hashref; + +# Create mailing index ID + my $mailing = $db_mli->insert( + mli_from => $info->{msg_from_email}, + mli_name => $info->{msg_from_name}, + mli_reply_to => $info->{msg_reply_to}, + mli_bounce_email => $info->{msg_bounce_email}, + mli_subject => $info->{msg_subject}, + mli_charset => $info->{msg_charset} || 'us-ascii', + mli_message_html => $info->{msg_content_html}, + mli_message_text => $info->{msg_content_text}, + mli_track_open => $info->{msg_track_open}, + mli_track_click => $info->{msg_track_click}, + mli_user_id_fk => $USER->{usr_username}, + )->insert_id; + $sent++; + + $db_eml->insert_multiple( + [qw/eml_mailing_id_fk eml_code eml_email eml_name eml_lists/], + map [$mailing, 'N/A', @$_], @subs + ) or die $GT::SQL::error; + +# Update the attachments + if ( @$attachs ) { + require GT::File::Tools; + my $attach_path = "$CFG->{priv_path}/attachments"; + mkdir("$attach_path/mailings/" . ($mailing % 10) . "/$mailing", 0777); + foreach (@$attachs) { + my $attach_id = $db_mat->insert( + mat_mailing_id_fk => $mailing, + mat_file_name => $_->{att_file_name}, + mat_file_size => $_->{att_file_size} + )->insert_id; + GT::File::Tools::copy("$attach_path/messages/" . ($info->{msg_id} % 10) . "/$info->{msg_id}/$_->{att_id}", "$attach_path/mailings/" . ($mailing % 10) . "/$mailing/$attach_id"); + } + } + $db_msg->update({ msg_status => '1' }, { msg_id => $info->{msg_id} }); + } + + require GList::Mailer; + $MN_SELECTED = 3; + GList::Mailer::mli_home(GList::language('MLI_CREATED_SUCCESS', $sent)); +} +END_OF_SUB + +$COMPILE{msg_move} = <<'END_OF_SUB'; +sub msg_move { +#-------------------------------------------------------------------- +# Moves the records to another category +# + return home(GList::language('SYS_MOVE_ERR')) unless ($IN->param('modify')); + return msg_home(GList::language('SYS_TARGET_ERR')) unless ($IN->param('move_to')); + +# Check category ID + my $to = $IN->param('move_to'); + if ($to ne 'root') { # Move to a sub-category + my $info = GList::check_owner('CatMessages', 'cms', $to); + return home($info) if (ref $info ne 'HASH'); + } + +# Need to know the number of records modified + my $rec_modified = 0; + my $rec_declined = 0; + + my $mod = (ref $IN->param('modify') eq 'ARRAY') ? $IN->param('modify') : [$IN->param('modify')]; + my $db = $DB->table('Messages'); + +# For through the record numbers. These are the values of the check boxes + foreach my $rec_num (@$mod) { + my $change = {}; + $change->{msg_id} = $IN->param("$rec_num-msg_id") if ($IN->param("$rec_num-msg_id")); + +# Check if users can modify only their own records + if ($USER->{usr_type} != ADMINISTRATOR) { + my $rs = $db->get($change); + next if (!$rs); + if ($rs->{'msg_user_id_fk'} ne $USER->{usr_username}) { + $rec_declined++; next; + } + } + + next unless (keys %$change); + my $ret; + if ($to eq 'root') { + $ret = $db->update({ msg_cat_id_fk => 0 }, $change); + } + else { + $ret = $db->update({ msg_cat_id_fk => $to }, $change); + } + if (defined $ret and ($ret != 0)) { + $rec_modified++; + } + } + msg_home(($rec_declined) ? GList::language('SYS_MOVED2', $rec_modified, $rec_declined) : GList::language('SYS_MOVED', $rec_modified)); +} +END_OF_SUB + +$COMPILE{msg_delete} = <<'END_OF_SUB'; +sub msg_delete { +#-------------------------------------------------------------------- +# Delete messages +# + return msg_home(GList::delete('Messages', 'msg')); +} +END_OF_SUB + +$COMPILE{msg_fview} = <<'END_OF_SUB'; +sub msg_fview { +#---------------------------------------------------------------------- +# View a attached file +# + return GList::view_file(); +} +END_OF_SUB + +$COMPILE{msg_fdownload} = <<'END_OF_SUB'; +sub msg_fdownload { +#---------------------------------------------------------------------- +# Download a attached file +# + return GList::download_file(); +} +END_OF_SUB + +$COMPILE{msg_cat_add} = <<'END_OF_SUB'; +sub msg_cat_add { +#-------------------------------------------------------------------- +# Add a category +# + my $name = $IN->param('cms_name'); + return msg_home(GList::language('SYS_ADD_INVALID')) unless ($name); + + my $ret = GList::add('CatMessages', 'cms', { cms_name => $name }); + return msg_home($GList::error) if ( $GList::error ); + return msg_home(GList::language('DIR_ADDED', $name)) if ( $ret ); +} +END_OF_SUB + +$COMPILE{msg_cat_modify} = <<'END_OF_SUB'; +sub msg_cat_modify { +#------------------------------------------------------------------- +# Update a category +# + return msg_home(GList::language('SYS_ADD_INVALID')) unless ($IN->param('cms_id')); + + GList::modify('CatMessages', 'cms'); + return msg_home($GList::error) if ( $GList::error ); + + msg_home(GList::language('DIR_UPDATED', $IN->param('cms_name'))); +} +END_OF_SUB + +$COMPILE{msg_cat_delete} = <<'END_OF_SUB'; +sub msg_cat_delete { +#-------------------------------------------------------------------- +# Delete a category +# + my $cgi = $IN->get_hash(); + + return msg_home(GList::language('SYS_ADD_INVALID')) unless ($cgi->{cms_id}); + + $cgi->{modify} = '1'; + $cgi->{'1-cms_id'} = $cgi->{cms_id}; + + return msg_home(GList::delete('CatMessages', 'cms', $cgi, GList::language('DIR_DELETED', $IN->param('cms_name')))); +} +END_OF_SUB + +$COMPILE{_add_attach} = __LINE__ . <<'END_OF_SUB'; +sub _add_attach { +#-------------------------------------------------------------------- +# Adds an attachment for a message +# + return GList::language('MSG_ATTACH_ERR') unless ($IN->param('attachment')); + + my $attachment = $IN->param('attachment'); + (my $filename = $attachment) =~ s/.*[\/\\]//; + my $user_file = $filename; + + my ($buffer, $count) = ('', 0); + +# Check if file is existed + while (-e "$CFG->{priv_path}/tmp/$count$filename") { + $count++; + } + $filename = "$count$filename"; + + open (OUTFILE,">> $CFG->{priv_path}/tmp/$filename") or return GList::language('SYS_FILE_ERR', $!); + binmode($attachment); + binmode(OUTFILE); + while (my $bytesread = read($attachment, $buffer, 1024)) { + print OUTFILE $buffer; + } + close (OUTFILE); + + return _get_attachments($user_file, $filename); +} +END_OF_SUB + +$COMPILE{_del_attach} = __LINE__ . <<'END_OF_SUB'; +sub _del_attach { +# ------------------------------------------------------------------ +# Removes an attachment from the list of attachments for a message +# + my $in = $IN->get_hash(); + my $dels = ( ref $IN->param('del_attach') eq 'ARRAY' ) ? $IN->param('del_attach') : [$IN->param('del_attach')]; + my %exist; + require GT::File::Tools; + foreach my $del (@$dels) { + $exist{$del} = 1; + if (-d "$CFG->{priv_path}/tmp/$del") { + GT::File::Tools::deldir("$CFG->{priv_path}/tmp/$del"); + } + else { + unlink ("$CFG->{priv_path}/tmp/$del"); + } + } + + my @attachments; + foreach my $file (grep (m/^attach-/, (keys %$in))) { + $file =~ /^attach-(.*)/; + next if $exist{$1}; + my $fsize = _get_fsize("$CFG->{priv_path}/tmp/$1"); + push (@attachments, { user_fname => $in->{$file}, fname => $1, fsize => $fsize}); + } + return \@attachments; +} +END_OF_SUB + +$COMPILE{_get_attachments} = __LINE__ . <<'END_OF_SUB'; +sub _get_attachments { +# ------------------------------------------------------------------ +# Generates the list of attachments +# + my ($user_file, $fname) = @_; + + my (@attachments, $fsize); + my $in = $IN->get_hash(); + + foreach my $file (grep (m/^attach-/, (keys %$in))) { + $file =~ /^attach-(.*)/; + $fsize = _get_fsize("$CFG->{priv_path}/tmp/$1"); + push @attachments, { user_fname => $in->{$file}, fname => $1, fsize => $fsize }; + } + if ($user_file) { + $fsize = _get_fsize("$CFG->{priv_path}/tmp/$fname"); + push @attachments, { user_fname => $user_file, fname => $fname, fsize => $fsize }; + } + return if (!scalar(@attachments)); + return \@attachments; +} +END_OF_SUB + +$COMPILE{_get_fsize} = __LINE__ . <<'END_OF_SUB'; +sub _get_fsize { +#------------------------------------------------------------------- +# + my $file = shift; + if (-d $file) { + opendir (DIR, $file) or return; + my @list = readdir(DIR); + closedir(DIR); + my $size = 0; + foreach (@list) { + ($_ =~ /\.|\.\./) and next; + $size += -s "$file/$_"; + } + return $size; + } + else { + return -s $file; + } +} +END_OF_SUB + +$COMPILE{_size_attachments} = __LINE__ . <<'END_OF_SUB'; +sub _size_attachments { +# ------------------------------------------------------------------ +# Generates the total size of the attachments for a message +# + my $in = $IN->get_hash(); + my $count; + foreach my $file (grep (m/^attach-/, (keys %$in))) { + $file =~ /^attach-(.*)/; + $count += -s "$CFG->{priv_path}/tmp/$1"; + } + return $count / 1024; +} +END_OF_SUB + +$COMPILE{_load_attachments} = __LINE__ . <<'END_OF_SUB'; +sub _load_attachments { +# ------------------------------------------------------------------ +# Generates the list of attachments from database +# + my $id = shift; + require GT::File::Tools; + + my $sth = $DB->table('MessageAttachments')->select({ att_message_id_fk => $id }); + my @attachments; + while (my $rs = $sth->fetchrow_hashref) { + my $filename = $rs->{att_file_name}; + my $count = ''; + while (-e "$CFG->{priv_path}/tmp/$count$filename") { + $count++; + } + $filename = "$count$filename"; + GT::File::Tools::copy("$CFG->{priv_path}/attachments/messages/" . ($id % 10) . "/$id/$rs->{att_id}", + "$CFG->{priv_path}/tmp/$filename"); + push @attachments, { user_fname => $rs->{att_file_name}, fname => $filename, fsize => $rs->{att_file_size} }; + } + return \@attachments; +} +END_OF_SUB + +$COMPILE{_load_navigator} = __LINE__ . <<'END_OF_SUB'; +sub _load_navigator { +#--------------------------------------------------------------------- +# Generates Category listings +# + my $user = GList::load_condition(); + my $db = $DB->table('CatMessages', 'Messages'); + my $cond = GT::SQL::Condition->new('cms_user_id_fk', $user->{opt} , $user->{id}); + $db->select_options('GROUP BY cms_id, cms_name ORDER BY cms_name'); + + my $sth = $db->select('left_join', $cond, ['CatMessages.cms_id', 'CatMessages.cms_name', 'count(msg_id) as messages']) or die $GT::SQL::error; + my $output; + while (my $rs = $sth->fetchrow_hashref) { + push @$output, $rs; + } + + my @items = ('cd', 'cs'); +# Create the URL + my $url = ''; + foreach (@items) { + $url .= "$_=".$IN->param($_).'&' if ( $IN->param($_) ); + } + chop $url; + +# Get category's information + my $info = {}; + if ($IN->param('msg_cat_id_fk')) { + $info = GList::check_owner('CatMessages', 'cms', $IN->param('msg_cat_id_fk')); + if ( ref $info ne 'HASH' ) { + $info = {}; + $info->{msg_cat_id_fk} = 0; + } + } + + my $constraints = GT::SQL::Condition->new( + msg_user_id_fk => $user->{opt} => $user->{id}, + msg_cat_id_fk => '=' => 0, + ); + my $hit_root = $DB->table('Messages')->select( $constraints )->rows; + return { url => $url, results_cat => $output, hits_cat => $#$output + 1, hits_root => $hit_root, %$info }; +} +END_OF_SUB + +$COMPILE{_switch_editor_mode} = __LINE__ . <<'END_OF_SUB'; +sub _switch_editor_mode { + my $html = $IN->param('msg_content_html') || ''; + my $text = $IN->param('msg_content_text') || ''; + my $mode = $IN->param('emode') || 'text'; + if ($html =~ /^\s*\s*\s*<\/BODY>\s*<\/html>\s*$/mi or + $html =~ /^\s*\s*\s*<\/body>\s*<\/html>\s*$/mi or + $html =~ /^\s*\s*

      \ <\/p><\/BODY>\s*<\/html>\s*$/mi or + $html =~ /^\s*\s*

      \ <\/P><\/BODY>\s*<\/html>\s*$/mi) { + $html = ""; + } + my %content; + if ($mode eq 'text') { + $content{msg_content_text} = _convert_to_text($html) if ($html); + } + elsif ($mode eq 'html') { + $content{msg_content_html} = _convert_to_html($text) if ($text); + } + else { + $content{msg_content_text} = _convert_to_text($html) if ($html); + $content{msg_content_html} = _convert_to_html($text) if ($text); + } +# $content{msg_content_html} = $IN->html_escape($html); + return \%content; +} +END_OF_SUB + +$COMPILE{_convert_to_text} = __LINE__ . <<'END_OF_SUB'; +sub _convert_to_text { +# Takes the text and checks it for html tags. If +# it contains html tags converts it to text. If it does not just +# returns it. +# + my $text = shift || ''; + ($text =~ /<\/?(?:br|p|html)>/i) or return $text; + _html_to_text(\$text); + $text =~ s//>/g; + $text =~ s/"/"/g; + return $text; +} +END_OF_SUB + +$COMPILE{_convert_to_html} = __LINE__ . <<'END_OF_SUB'; +sub _convert_to_html { +# ------------------------------------------------------------------ +# Checks content for html tags, if it contains html this method +# will just return it. If it does not this method will convert the +# text to html. This means converting \n to
      amoung other things. +# + my $text = shift || ''; + #($text =~ /<\/?(?:br|p|html)>/i) and return; + #$text =~ s{\b((?:https?|ftp)://(?:[^@]*@)?[\w.-]+(?:/\S*)?)}{$1}gi; + $IN->html_escape(\$text); + _text_to_html(\$text); + return $text; +} +END_OF_SUB + +$COMPILE{_text_to_html} = __LINE__ . <<'END_OF_SUB'; +sub _text_to_html { +# ------------------------------------------------------------------ +# Internal method to convert text to html +# + my $convert = shift; + $$convert =~ s/\r?\n/
      \n/g; +} +END_OF_SUB + +$COMPILE{_html_to_text} = __LINE__ . <<'END_OF_SUB'; +sub _html_to_text { +# ------------------------------------------------------------------ +# Internal method to convert html to text. +# + my $convert = shift; + + my $dash = ('-' x 60); + +# This will break

      'ed text, but it fixes a lot problems with regular conversions
      +    $$convert =~ s/\r?\n//g;
      +    $$convert =~ s/\r//g;
      +    $$convert =~ s/ +/ /g;
      +
      +    $$convert =~ s/ / /ig;
      +    $$convert =~ s/"/"/ig;
      +    $$convert =~ s/&/&/ig;
      +    $$convert =~ s/©/(C)/ig;
      +    $$convert =~ s/®/(R)/ig;
      +    $$convert =~ s/™/^TM/ig;
      +
      +    $$convert =~ s///sg;
      +    $$convert =~ s/
    • \s*(.*?)\s*<\/li>/\n* $1\n/sig; + $$convert =~ s/
    • \s*([^<]*)/\n* $1/sig; + $$convert =~ s[]*>][\n\n]ig; + $$convert =~ s/]*>/\n/ig; + $$convert =~ s[]*>][\n]ig; +# $$convert =~ s[([^<]*)][*$1*]ig; +# $$convert =~ s[([^<]*)][_$1_]ig; + $$convert =~ s[]*>][\n\n]ig; + $$convert =~ s/]*>/\n$dash\n/ig; + my @tokens = split /(<[^>"']*(?:(?:(?:"[^"]*"[^>"]*)|(?:'[^']*'[^>']*)))*>)/, $$convert; + $$convert = join '' => map { $tokens[$_] } grep { not $_ % 2 } 0 .. $#tokens; + $$convert =~ s/<//ig; + $$convert =~ s/^[ \t]+//gm; + $$convert =~ s/[ \t]+$//gm; +} +END_OF_SUB + +$COMPILE{_spellcheck} = __LINE__ . <<'END_OF_SUB'; +sub _spellcheck { + my ($content, $is_html) = @_; + + my (@parts, @words, @non_words); + if ($is_html) { + @parts = split m{((?:<(?:[^>"']+|"[^"]*"|'[^']*')*>|[^a-zA-Z'<]+)+)}, $content; + } + else { + @parts = split m{([^a-zA-Z']+)}, $content; + } + + for (@parts) { + next unless length; + if (/[^a-zA-Z']/) { + push @non_words, $_; + push @words, undef; + next; + } + if (s/^('+)//) { + push @non_words, $1; + push @words, undef; + } + + my $end_apos; + if (s/('+)$//) { + $end_apos = $1; + } + if ($_ =~ /^(?:nbsp|amp|gt|lt)$/i ) { + push @words, undef; + push @non_words, $_; + } + elsif (/^[a-zA-Z']{2,}$/) { + push @words, $_; + push @non_words, undef; + } + else { + push @non_words, $_; + push @words, undef; + } + if ($end_apos) { + push @non_words, $end_apos; + push @words, undef; + } + } + + require GT::SpellCheck; + my @check_words = map { (defined() ? (lc) : ()) } @words; + my $data = "$CFG->{priv_path}/lib/GT/SpellCheck"; + my $sp = new GT::SpellCheck( + word_path => "$data/wordlist.ndx", + sndex_path => "$data/sndex.ndx", + acorrect_path => "$data/acorrect.ndx", + max_words => 10, + similarity_sort => 1 + ); + my $misspelled = $sp->check_words(\@check_words); + + my $custom = $DB->table('CustomDict')->select(['custom_words'], { username_fk => $USER->{usr_username} }); + $custom = $custom->fetchrow; + for ($custom ? split /\n/, $custom : ()) { + delete $misspelled->{lc $_}; + } + + my $corrections = [map +{ word => lc(), corrections => [ map +{ correction => $_ }, @{$misspelled->{$_}} ], num_corrections => scalar @{$misspelled->{$_}} }, keys %$misspelled]; + my @loop; + for (0 .. $#words) { + if (defined $words[$_]) { + my $misspelled = exists $misspelled->{lc $words[$_]} ? 1 : 0; + if (@loop and not $loop[-1]->{misspelled} and not $misspelled) { + $loop[-1]->{word} .= $words[$_]; + } + else { + push @loop, { word => $words[$_], misspelled => $misspelled }; + } + } + else { + if (@loop and not $loop[-1]->{misspelled}) { + $loop[-1]->{word} .= $non_words[$_]; + } + else { + push @loop, { word => $non_words[$_], misspelled => 0 }; + } + } + } + + my $misspellings = ''; + $misspellings = join ",\n", map { + qq|"$_->{word}" : [| . join(",", map(qq: "$_->{correction}":, @{$_->{corrections}})) . "]" + } @$corrections; + return { words => \@loop, misspellings => \$misspellings }; +} +END_OF_SUB + +$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB'; +sub _determine_action { +#---------------------------------------------------------------------------- +# Check valid action + + my $action = shift || undef; + return if (!$action); + return 'msg_home' if ($action eq 'msg_search'); + + my %valid = ( + map { $_ => 1 } qw( + msg_page + msg_home + msg_add_form + msg_add + msg_modify_form + msg_modify + msg_search_form + msg_send_sample + msg_send_form + msg_send + msg_move + msg_delete + msg_fview + msg_fdownload + msg_cat_add + msg_cat_modify + msg_cat_delete + msg_spellcheck + msg_addword + ) + ); + exists $valid{$action} and return $action; + return; +} +END_OF_SUB + +1; + diff --git a/site/glist/lib/GList/Plugins.pm b/site/glist/lib/GList/Plugins.pm new file mode 100644 index 0000000..e180b21 --- /dev/null +++ b/site/glist/lib/GList/Plugins.pm @@ -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; + diff --git a/site/glist/lib/GList/Plugins/SubscribersMod.pm b/site/glist/lib/GList/Plugins/SubscribersMod.pm new file mode 100644 index 0000000..84cc4a3 --- /dev/null +++ b/site/glist/lib/GList/Plugins/SubscribersMod.pm @@ -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 . "
      ".Dumper($old_data,$update)."
      "; + $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; diff --git a/site/glist/lib/GList/Profile.pm b/site/glist/lib/GList/Profile.pm new file mode 100644 index 0000000..de863c0 --- /dev/null +++ b/site/glist/lib/GList/Profile.pm @@ -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("$GT::SQL::error"); + } +} +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 => "$GT::SQL::error" }); + } +} +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) : '') + . '
      '; + } + 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"; + $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 $cgi->{date_from}"; + $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 $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; diff --git a/site/glist/lib/GList/SQL.pm b/site/glist/lib/GList/SQL.pm new file mode 100644 index 0000000..ca3b754 --- /dev/null +++ b/site/glist/lib/GList/SQL.pm @@ -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; + + diff --git a/site/glist/lib/GList/Template.pm b/site/glist/lib/GList/Template.pm new file mode 100644 index 0000000..20f05fd --- /dev/null +++ b/site/glist/lib/GList/Template.pm @@ -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 => <
      {$_}; + 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; diff --git a/site/glist/lib/GList/Tools.pm b/site/glist/lib/GList/Tools.pm new file mode 100644 index 0000000..2f2a953 --- /dev/null +++ b/site/glist/lib/GList/Tools.pm @@ -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} ) ? "" + : ""; + } + else { + $html .= ( $current == $rs->{lst_id} ) ? "" + : ""; + } + } + 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 = 'Edit email template has been disabled in the demo!'; + } + 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 ) ? "$GT::SQL::error" : GList::language('TPL_UPDATED', $save_as); + } + else { # Add a new template + $db->insert($hsh); + $msg = ( $GT::SQL::error ) ? "$GT::SQL::error" : 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 = 'Edit email template has been disabled in the demo !'; + } + 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 ) ? "$GT::SQL::error" : 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 ) ? "$GT::SQL::error" : 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 = 'The language editor has been disabled in the demo!'; + } + 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 .= < + $code + + + + + +HTML + } + my $prefix_output = join " | ", + map qq'$_ ($prefix_list{$_})', + 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 = 'The global editor has been disabled in the demo!'; + } + 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 .= < + $code + + + + + +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 = ""; +} + +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 = ""; + + 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; diff --git a/site/glist/lib/GList/User.pm b/site/glist/lib/GList/User.pm new file mode 100644 index 0000000..ccb976b --- /dev/null +++ b/site/glist/lib/GList/User.pm @@ -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 => "$GList::error" }) 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 => "$results->{error}" }) 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; diff --git a/site/glist/lib/GList/mod_perl.pm b/site/glist/lib/GList/mod_perl.pm new file mode 100644 index 0000000..4a78c97 --- /dev/null +++ b/site/glist/lib/GList/mod_perl.pm @@ -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; diff --git a/site/glist/lib/GT/AutoLoader.pm b/site/glist/lib/GT/AutoLoader.pm new file mode 100644 index 0000000..27b16fb --- /dev/null +++ b/site/glist/lib/GT/AutoLoader.pm @@ -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 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 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, in its standard behaviour, simply put: +C in your module. When you use GT::AutoLoader, two things +will happen. First, an C 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 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 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 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 + +=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 diff --git a/site/glist/lib/GT/Base.pm b/site/glist/lib/GT/Base.pm new file mode 100644 index 0000000..5805ade --- /dev/null +++ b/site/glist/lib/GT/Base.pm @@ -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 = '
      '; + $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 diff --git a/site/glist/lib/GT/CGI.pm b/site/glist/lib/GT/CGI.pm new file mode 100644 index 0000000..ed312e4 --- /dev/null +++ b/site/glist/lib/GT/CGI.pm @@ -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 . <Document Moved + +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; + } + else { + $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; + } + else { + $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 and L, and if you are +performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L. +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 diff --git a/site/glist/lib/GT/CGI/Action.pm b/site/glist/lib/GT/CGI/Action.pm new file mode 100644 index 0000000..9c455f1 --- /dev/null +++ b/site/glist/lib/GT/CGI/Action.pm @@ -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__ + + diff --git a/site/glist/lib/GT/CGI/Action/Common.pm b/site/glist/lib/GT/CGI/Action/Common.pm new file mode 100644 index 0000000..921dbe3 --- /dev/null +++ b/site/glist/lib/GT/CGI/Action/Common.pm @@ -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__ + + diff --git a/site/glist/lib/GT/CGI/Action/Plugin.pm b/site/glist/lib/GT/CGI/Action/Plugin.pm new file mode 100644 index 0000000..24c82d2 --- /dev/null +++ b/site/glist/lib/GT/CGI/Action/Plugin.pm @@ -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__ + + diff --git a/site/glist/lib/GT/CGI/Cookie.pm b/site/glist/lib/GT/CGI/Cookie.pm new file mode 100644 index 0000000..d747b14 --- /dev/null +++ b/site/glist/lib/GT/CGI/Cookie.pm @@ -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; diff --git a/site/glist/lib/GT/CGI/EventLoop.pm b/site/glist/lib/GT/CGI/EventLoop.pm new file mode 100644 index 0000000..15de9a1 --- /dev/null +++ b/site/glist/lib/GT/CGI/EventLoop.pm @@ -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 .= ''; + } + 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; + + diff --git a/site/glist/lib/GT/CGI/Fh.pm b/site/glist/lib/GT/CGI/Fh.pm new file mode 100644 index 0000000..1c46d1d --- /dev/null +++ b/site/glist/lib/GT/CGI/Fh.pm @@ -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; diff --git a/site/glist/lib/GT/CGI/MultiPart.pm b/site/glist/lib/GT/CGI/MultiPart.pm new file mode 100644 index 0000000..6c47d9f --- /dev/null +++ b/site/glist/lib/GT/CGI/MultiPart.pm @@ -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; diff --git a/site/glist/lib/GT/Cache.pm b/site/glist/lib/GT/Cache.pm new file mode 100644 index 0000000..d378c70 --- /dev/null +++ b/site/glist/lib/GT/Cache.pm @@ -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 diff --git a/site/glist/lib/GT/Config.pm b/site/glist/lib/GT/Config.pm new file mode 100644 index 0000000..4c2e1f8 --- /dev/null +++ b/site/glist/lib/GT/Config.pm @@ -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) and mtime-based +caching. + +=head1 METHODS + +=head2 load + +There is no C 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 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 0> to disable cached loading. +Note that new objects are always stored in the cache, allowing you to specify +C 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 1> if the config file doesn't +necessarily have to exist (i.e. when creating a new config file). + +=item empty + +The C option is used to create a new, blank config file - it can be +thought of as a forced version of the C option. It won't read +B files during loading (and as such completely ignores the C +and C 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 option is used to specify the mode of the saved file. It must be +passed in octal form, such as 0644 (but B 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{foo}-E{bar}> will not fatal if C is a +hash ref, but C is not set in that hash reference. C<$CFG-E{foo}> +(and C<$CFG-E{foo}-E{bar}>) will fatal if the key C 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, 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 when saving, which is +generally a value such as: C. + +=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 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) when L. + +B The argument to compile_subs must be a valid perl package; the code +reference will be compiled in that package. For example, +C '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::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-Esave()>. 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: B. 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 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 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::Config always sorts hash keys - this can be used when the default +alphanumeric sort is not sufficient. + +=head1 SEE ALSO + +L + +=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 diff --git a/site/glist/lib/GT/Date.pm b/site/glist/lib/GT/Date.pm new file mode 100644 index 0000000..0c59e7c --- /dev/null +++ b/site/glist/lib/GT/Date.pm @@ -0,0 +1,1128 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Date +# Author : Aki Mimoto +# CVS Info : +# $Id: Date.pm,v 1.75 2005/04/04 22:21:23 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Generic date manipulation routines. Exports functions to use. +# + +package GT::Date; +# =============================================================== +# This package implements the date handling routines. +# The default date format is yyyy-mm-dd as in 1999-12-25. To change the +# format, edit $DATE_FMT and use any of the following: +# +# yyyy - four digit year as in 1999 +# yy - two digit year as in 99 +# y - two digit year without leading 0 +# mmmm - long month name as in January +# mmm - short month name as in Jan +# mm - numerical month name as in 01 +# m - same as mm, but without leading 0's for months 1-9 +# dddd - long day name as in Sunday +# ddd - short day name as in Sun +# dd - numerical date +# d - numerical date without leading 0 +# HH - numerical hours (24 hour time) +# H - numerical hours without leading 0 (24 hour time) +# hh - numerical hours (12 hour time) +# h - numerical hours without leading 0 (12 hour time) +# MM - numerical minutes +# M - numerical minutes without leading 0 +# ss - numerical seconds +# s - numerical seconds without leading 0 +# tt - AM or PM (use with 12 hour time) +# o - + or - gm offset +# +# Common formats: +# %yyyy%-%mm%-%dd% 1999-12-25 +# %dd%-%mmm%-%yyyy% 12-Dec-1999 +# %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 +# %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 +# +# RFC822 +# %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800 +# +# MySQL +# %yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02 +# + +use strict; +use vars qw/$GM_OFFSET $GM_OFFSET_DST @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DATE_FMT $RANGE_CHECK + $VERSION $AUTOLOAD $LANGUAGE $OFFSET %GMTTIME $LOUD/; +use GT::Cache; +use Exporter; +use GT::AutoLoader; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.75 $ =~ /(\d+)\.(\d+)/; +@ISA = qw/Exporter/; +@EXPORT_OK = qw/timelocal timegm date_is_valid date_is_greater date_is_smaller date_get date_get_gm date_gmt_offset + date_comp date_diff date_add date_add_gm date_sub date_sub_gm date_http_gmt + date_set_month date_set_month_short date_set_days date_set_days_short + date_set_format date_get_format date_transform parse_format format_date + /; +%EXPORT_TAGS = ( all => \@EXPORT_OK, timelocal => [ qw(timelocal timegm) ] ); + +# Module Options. +$DATE_FMT = "%yyyy%-%mm%-%dd%"; +$OFFSET = 0 * 3600; +$RANGE_CHECK = 0; +$LOUD = 0; +$LANGUAGE = { + 'month_names' => [qw/January February March April May June July August September October November December/], + 'day_names' => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/], + 'short_month_names' => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/], + 'short_day_names' => [qw/Sun Mon Tue Wed Thu Fri Sat/] +}; + +# Time strings to GM offset in minutes +%GMTTIME = ( + GMT => 0, + UT => 0, + BST => 60, + IST => 60, + WET => 0, + WEST => 60, + CET => 60, + CEST => 120, + EET => 120, + EEST => 180, + MSK => 180, + MSD => 240, + AST => -240, + ADT => -180, + EST => -300, + EDT => -240, + ET => -300, + CST => -360, + CDT => -300, + CT => -360, + MST => -420, + MDT => -360, + MT => -420, + PST => -480, + PDT => -420, + PT => -480, + HST => -600, + AKST => -540, + AKDT => -480, + WST => 480, +); + +# Set up our Cache objects. +use vars qw( + @MONTHS %MONTHS @DAYS %DAYS @MONTHS_SH %MONTHS_SH @DAYS_SH %DAYS_SH %MONTH_HASH + %DATE_TO_TM %DATE_TRANS %MONTH_YEAR +); + +tie %DATE_TO_TM, 'GT::Cache', 500, \&_date_str_to_time; +tie %DATE_TRANS, 'GT::Cache', 500, \&_transform; +tie %MONTH_YEAR, 'GT::Cache', 500, \&_calc_my; + +# Constants in calculating the time array => unix time. +use constants + SEC => 1, + MIN => 60, # 60 * SEC + HOUR => 3600, # 60 * MIN + DAY => 86400; # 24 * HOUR + +build_lang(); + +sub build_lang { +# ---------------------------------------------------- +# Build vars to use internally. +# + @MONTHS = @{$LANGUAGE->{month_names}}; my $i = 0; + %MONTHS = map { $_ => $i++ } @MONTHS; + @DAYS = @{$LANGUAGE->{day_names}}; $i = 0; + %DAYS = map { $_ => $i++ } @DAYS; + @MONTHS_SH = @{$LANGUAGE->{short_month_names}}; $i = 0; + %MONTHS_SH = map { $_ => $i++ } @MONTHS_SH; + @DAYS_SH = @{$LANGUAGE->{short_day_names}}; $i = 0; + %DAYS_SH = map { $_ => $i++ } @DAYS_SH; + %MONTH_HASH = map { ( $MONTHS[$_] => $_, $MONTHS_SH[$_] => $_ ) } ( 0..11 ); +} + +$COMPILE{date_set_format} = __LINE__ . <<'END_OF_SUB'; +sub date_set_format { +# ---------------------------------------------------- +# Set the date format to use, make sure to clear caches. +# + $DATE_FMT = shift; + %DATE_TO_TM = (); +} +END_OF_SUB + +$COMPILE{date_get_format} = __LINE__ . <<'END_OF_SUB'; +sub date_get_format { +# ---------------------------------------------------- +# Set the date format to use. +# + return $DATE_FMT; +} +END_OF_SUB + +$COMPILE{date_set_month} = __LINE__ . <<'END_OF_SUB'; +sub date_set_month { +# ---------------------------------------------------- +# Set the language. +# + my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; + $LANGUAGE->{month_names} = $lang; + build_lang(); +} +END_OF_SUB + +$COMPILE{date_set_month_short} = __LINE__ . <<'END_OF_SUB'; +sub date_set_month_short { +# ---------------------------------------------------- +# Set the language. +# + my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; + $LANGUAGE->{short_month_names} = $lang; + build_lang(); +} +END_OF_SUB + +$COMPILE{date_set_days} = __LINE__ . <<'END_OF_SUB'; +sub date_set_days { +# ---------------------------------------------------- +# Set the language. +# + my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; + $LANGUAGE->{day_names} = $lang; + build_lang(); +} +END_OF_SUB + +$COMPILE{date_set_days_short} = __LINE__ . <<'END_OF_SUB'; +sub date_set_days_short { +# ---------------------------------------------------- +# Set the language. +# + my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; + $LANGUAGE->{short_day_names} = $lang; + build_lang(); +} +END_OF_SUB + +$COMPILE{date_is_valid} = __LINE__ . <<'END_OF_SUB'; +sub date_is_valid { +# ---------------------------------------------------- +# Check whether a string is a valid date. +# + my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + return $DATE_TO_TM{$key}; +} +END_OF_SUB + +$COMPILE{date_is_greater} = __LINE__ . <<'END_OF_SUB'; +sub date_is_greater { +# ---------------------------------------------------- +# Returns 1 if the first date is larger then the second. +# + (date_comp(@_) == 1) ? return 1 : return undef; +} +END_OF_SUB + +$COMPILE{date_is_smaller} = __LINE__ . <<'END_OF_SUB'; +sub date_is_smaller { +# ---------------------------------------------------- +# Returns 1 if the first date is smaller then the second. +# + (date_comp(@_) == -1) ? return 1 : return undef; +} +END_OF_SUB + +$COMPILE{date_get} = __LINE__ . <<'END_OF_SUB'; +sub date_get { +# ---------------------------------------------------- +# Return today's date or a date from a time() that you +# pass in. Optionally takes a second argument as a +# date format to return the result in. Any offset will +# be added to the date as required. +# + my $time = shift || time; + $time += $OFFSET if $OFFSET; + my $fmt = shift || $DATE_FMT; + my @date = localtime($time); + return format_date(\@date, $fmt); +} +END_OF_SUB + +$COMPILE{date_get_gm} = __LINE__ . <<'END_OF_SUB'; +sub date_get_gm { +# ---------------------------------------------------- +# Return today's date or a date from a time() that you +# pass in. Optionally takes a second argument as a +# date format to return the result in. +# + my $time = shift || time; + my $fmt = shift || $DATE_FMT; + my @date = gmtime($time); + return format_date(\@date, $fmt); +} +END_OF_SUB + +$COMPILE{date_comp} = __LINE__ . <<'END_OF_SUB'; +sub date_comp { +# ---------------------------------------------------- +# Equivalant to $date1 <=> $date2 +# + my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + return $DATE_TO_TM{$key1} <=> $DATE_TO_TM{$key2}; +} +END_OF_SUB + +$COMPILE{date_diff} = __LINE__ . <<'END_OF_SUB'; +sub date_diff { +# ---------------------------------------------------- +# Return number of days difference between two dates. +# + my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + return int (($DATE_TO_TM{$key1} - $DATE_TO_TM{$key2}) / DAY); +} +END_OF_SUB + +$COMPILE{date_add} = __LINE__ . <<'END_OF_SUB'; +sub date_add { +# ---------------------------------------------------- +# Returns argument a +- x days. +# + my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my @date = localtime($DATE_TO_TM{$key} + $_[1] * DAY); + return format_date(\@date); +} +END_OF_SUB + +$COMPILE{date_add_gm} = __LINE__ . <<'END_OF_SUB'; +sub date_add_gm { +# ---------------------------------------------------- +# Returns argument a +- x days. +# + my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my @date = gmtime($DATE_TO_TM{$key} + $_[1] * DAY); + return format_date(\@date); +} +END_OF_SUB + +$COMPILE{date_sub} = __LINE__ . <<'END_OF_SUB'; +sub date_sub { +# ---------------------------------------------------- +# Returns argument - days. +# + my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my @date = localtime($DATE_TO_TM{$key} - $_[1] * DAY); + return format_date(\@date); +} +END_OF_SUB + +$COMPILE{date_sub_gm} = __LINE__ . <<'END_OF_SUB'; +sub date_sub_gm { +# ---------------------------------------------------- +# Returns argument - days. +# + my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + my @date = gmtime($DATE_TO_TM{$key} - $_[1] * DAY); + return format_date(\@date); +} +END_OF_SUB + +$COMPILE{date_transform} = __LINE__ . <<'END_OF_SUB'; +sub date_transform { +# ---------------------------------------------------- +# Takes a date, followed by orig format and transforms to +# a new format. +# + my ($date, $orig, $new) = @_; + my $key = join("\0", $date, $orig, $new, @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); + return $DATE_TRANS{$key}; +} +END_OF_SUB + +$COMPILE{format_date} = __LINE__ . <<'END_OF_SUB'; +sub format_date { +# ---------------------------------------------------- +# Takes an array from localtime or equiv and a date format +# and returns date. +# + my $date = shift; + my $fmt = shift || $DATE_FMT; + my (@real, $time); + +# Make sure we have all the info. + for (0 .. $#{$date}) { + if (! defined $date->[$_]) { + if (!@real) { + $time = timelocal(@{$date}); + @real = localtime($time); + } + $date->[$_] = $real[$_]; + } + } + my ($sec, $min, $hour, $day, $mon, $year, $dwk) = @{$date}; + my $twelve_hour = $hour == 0 ? 12 : $hour > 12 ? $hour - 12 : $hour; + my $vals = { + ss => sprintf ("%02d", $sec), + s => $sec, + MM => sprintf ("%02d", $min), + M => $min, + HH => sprintf ("%02d", $hour), + H => $hour, + hh => sprintf ("%02d", $twelve_hour), + h => $twelve_hour, + tt => ($hour >= 12 ? "PM" : "AM"), + dd => sprintf ("%02d", $day), + d => $day, + mm => sprintf ("%02d", $mon + 1), + m => $mon + 1, + mmmm => defined $MONTHS[$mon] ? $MONTHS[$mon] : '', + mmm => defined $MONTHS_SH[$mon] ? $MONTHS_SH[$mon] : '', + dddd => defined $DAYS[$dwk] ? $DAYS[$dwk] : '', + ddd => defined $DAYS_SH[$dwk] ? $DAYS_SH[$dwk] : '', + yyyy => $year + 1900, + yy => sprintf ("%02d", $year % 100), + y => $year % 100, + o => sub { + my $offset = date_gmt_offset(); + return sprintf ("%+05d", int($offset / 3600) * 100 + int(($offset % 3600) /60)) + } + + }; + $fmt =~ s/%([^%]+)%/exists $vals->{$1} ? (ref($vals->{$1}) eq 'CODE') ? $vals->{$1}->() : $vals->{$1} : ''/eg; + return $fmt; +} +END_OF_SUB + +$COMPILE{parse_format} = __LINE__ . <<'END_OF_SUB'; +sub parse_format { +# ---------------------------------------------------- +# Takes a string and a date format and returns an array +# ref of the first 7 arguments returned by localtime(). +# + my $date = shift; + my $fmt = shift || $DATE_FMT; + return unless ($date); + + my $pos = 0; + my ($sec, $min, $hour, $pm, $day, $mon, $year, $dwk, $before, $type, $adjust, $leading, $h24); + while ($fmt =~ /([^%]*?)%([^%]+)%/g) { + $leading = $1; + $type = $2; + CASE: { +# yyyy - four digit year as in 1999 + ($type eq 'yyyy' and !defined $year) + and do { + $date =~ s/^\Q$leading\E(\d{4})// or return; + $year = int( int( $1 ) - 1900); + last CASE; + }; +# yy - two digit year as in 99 + ($type eq 'yy' and !defined $year) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $year = int $1; + if ( $year < 69 ) { # 20xx + $year += 2000; + } + else { # 19xx + $year += 1900; + } + $year = $year - 1900; + last CASE; + }; +# y - two digit year without leading 0 + ($type eq 'y' and !defined $year) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $year = int $1; + $year = 2000 + $year if $year < 40; + $year = $year - 1900; + last CASE; + }; +# mmmm - long month name as in January + ($type eq 'mmmm' and !defined $mon) + and do { + my $val; + for ( keys %MONTHS ) { + if ( index( $date, "$leading$_" ) == 0 ) { + $val = $_; + substr( $date, 0, length( $leading.$_ ) ) = ''; + last; + } + } + $val or return; + $mon = int $MONTHS{$val}; + last CASE; + }; +# mmm - short month name as in Jan + ($type eq 'mmm' and !defined $mon) + and do { + my $val; + for ( keys %MONTHS_SH ) { + if ( index( $date, "$leading$_" ) == 0 ) { + $val = $_; + substr( $date, 0, length( $leading.$_ ) ) = ''; + last; + } + } + $val or return; + $mon = int $MONTHS_SH{$val}; + last CASE; + }; +# mm - numerical month name as in 01 + ($type eq 'mm' and !defined $mon) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $mon = int( $1 - 1 ); + last CASE; + }; +# m - same as mm, but without leading 0's for months 1-9 + ($type eq 'm' and !defined $mon) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $mon = int( $1 - 1 ); + last CASE; + }; +# dddd - long day name as in Sunday + ($type eq 'dddd' and !defined $dwk) + and do { + my $val; + for ( keys %DAYS ) { + if ( index( $date, "$leading$_" ) == 0 ) { + $val = $_; + substr( $date, 0, length( $leading.$_ ) ) = ''; + last; + } + } + $val or return; + $dwk = int $DAYS{$val}; + last CASE; + }; +# ddd - short day name as in Sun + ($type eq 'ddd' and !defined $dwk) + and do { + my $val; + for ( keys %DAYS_SH ) { + if ( index( $date, "$leading$_" ) == 0 ) { + $val = $_; + substr( $date, 0, length( $leading.$_ ) ) = ''; + last; + } + } + $val or return; + $dwk = int $DAYS_SH{$val}; + last CASE; + }; +# dd - numerical date + ($type eq 'dd' and !defined $day) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $day = int $1; + last CASE; + }; +# d - numerical date without leading 0 + ($type eq 'd' and !defined $day) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $day = int $1; + last CASE; + }; +# HH - numerical hours (24 hour time) + ($type eq 'HH' and !defined $hour) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $hour = int $1; + $h24 = 1; + last CASE; + }; +# H - numerical hours without leading 0 (24 hour time) + ($type eq 'H' and !defined $hour) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $hour = int $1; + $h24 = 1; + last CASE; + }; +# hh - numerical hours (12 hour time) + ($type eq 'hh' and !defined $hour) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $hour = int $1; + last CASE; + }; +# h - numerical hours without leading 0 (12 hour time) + ($type eq 'h' and !defined $hour) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $hour = int $1; + last CASE; + }; +# MM - numerical minutes + ($type eq 'MM' and !defined $min) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $min = int $1; + last CASE; + }; +# M - numerical minutes without leading 0 + ($type eq 'M' and !defined $min) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $min = int $1; + last CASE; + }; +# ss - numerical seconds + ($type eq 'ss' and !defined $sec) + and do { + $date =~ s/^\Q$leading\E(\d{2})// or return; + $sec = int $1; + last CASE; + }; +# s - numerical seconds without leading 0 + ($type eq 's' and !defined $sec) + and do { + $date =~ s/^\Q$leading\E(\d?\d)// or return; + $sec = int $1; + last CASE; + }; +# tt - AM or PM (use with 12 hour time) + ($type eq 'tt' and !defined $pm) + and do { + $date =~ s/^\Q$leading\E([aApP][mM])// or return; + $pm = uc( $1 ) eq 'PM'; + last CASE; + }; +# o - + or - gm offset + ($type eq 'o' and !defined $adjust) + and do { + $date =~ s/^\Q$leading\E((?:\w{1,4})|(?:[+\-]?\d{3,4}))// or return; + $adjust = $1; + last CASE; + }; + return; + } + } + defined $day or ($day = 1); + defined $mon or ($mon = 0); + defined $sec or ($sec = 0); + defined $min or ($min = 0); + defined $hour or ($hour = 0); + if ($pm and $hour < 12) { + $hour += 12; + } + elsif (!$pm and !$h24 and $hour == 12) { + $hour = 0; + } + if (defined $day && defined $mon && defined $year) { + if (defined $adjust) { + my $minutes; + + if ($adjust =~ /^([+\-]?)(\d?\d)(\d\d)$/) { + my $neg = $1 || '+'; + if ($neg eq '-') { + $minutes -= ($2 * 60) + $3; + } + else { + $minutes = ($2 * 60) + $3; + } + } + elsif (exists $GMTTIME{$adjust}) { + $minutes = $GMTTIME{$adjust}; + } + if (defined $minutes) { + my $time = timelocal($sec, $min, $hour, $day, $mon, $year, $dwk); + my $gm_offset = date_gmt_offset(); + my $tm_offset = $minutes * 60; + $time = $time + ($gm_offset - $tm_offset); + + return [(localtime($time))[0..6]]; + } + } + + return [$sec, $min, $hour, $day, $mon, $year, $dwk]; + } + return; +} +END_OF_SUB + +$COMPILE{date_gmt_offset} = __LINE__ . <<'END_OF_SUB'; +sub date_gmt_offset { +# ---------------------------------------------------- +# Returns the offset from local to gmtime in seconds. +# This can be a negative number. +# + my @lt = localtime; + unless (defined $GM_OFFSET and $lt[8] == $GM_OFFSET_DST) { + $GM_OFFSET = timegm(@lt) - timelocal(@lt); + $GM_OFFSET_DST = $lt[8]; + } + return $GM_OFFSET; +} +END_OF_SUB + +$COMPILE{timelocal} = __LINE__ . <<'END_OF_SUB'; +sub timelocal { +# ------------------------------------------------------------------- +# Returns unix time from a timelocal array. +# + my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : localtime; + my $time = timegm (@date); + my $orig = $time; + + my @lt = localtime ($time); + my @gt = gmtime ($time); + + if ($time < DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) { + $orig += DAY; + @lt = localtime($orig); + @gt = gmtime($orig); + } + my $tzsec = ($gt[1] - $lt[1]) * MIN + ($gt[2] - $lt[2]) * HOUR; + + if ($lt[5] > $gt[5]) { + $tzsec -= DAY; + } + elsif ($gt[5] > $lt[5]) { + $tzsec += DAY; + } + else { + $tzsec += ($gt[7] - $lt[7]) * DAY; + } + $tzsec += HOUR if($lt[8]); + + my $ret = $time + $tzsec; + my @test = localtime($ret + ($orig - $time)); + $ret -= HOUR if $test[2] != $date[2]; + return $ret; +} +END_OF_SUB + +$COMPILE{timegm} = __LINE__ . <<'END_OF_SUB'; +sub timegm { +# ------------------------------------------------------------------- +# Returns gm unix time based on a timelocal/gmtime array. +# + my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : gmtime; + if ($date[5] > 999) { + $date[5] -= 1900; + } + while ($date[4] < 0) { # If a negative month gets passed in, add 12 months and subtract a year + $date[4] += 12; + $date[5]--; + } + while ($date[4] >= 12) { # If a month too large is passed in, subtract 12 months and add a year + $date[4] -= 12; + $date[5]++; + } + my $time_str = join "\0", map { defined $_ ? $_ : '' } @date; + my $time = $MONTH_YEAR{$time_str}; + $time + $date[0] * SEC + $date[1] * MIN + $date[2] * HOUR + ($date[3]-1) * DAY; +} +END_OF_SUB + +# ====================================================================== # +# PRIVATE FUNCTIONS # +# ====================================================================== # + +$COMPILE{_date_str_to_time} = __LINE__ . <<'END_OF_SUB'; +sub _date_str_to_time { +# ---------------------------------------------------- +# Takes a date string and converts it to a unix time. +# + return unless (defined $_[0]); + my ($date, @lang) = split /\0/, $_[0]; + if (@lang != 38) { + die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang; + } + local @MONTHS = @lang[0 .. 11]; + local @DAYS = @lang[12 .. 18]; + local @MONTHS_SH = @lang[19 .. 30]; + local @DAYS_SH = @lang[31 .. 37]; + my $time_arr = parse_format($date) or return 0; + return timelocal (@$time_arr); +} +END_OF_SUB + +$COMPILE{_format_date} = __LINE__ . <<'END_OF_SUB'; +sub _format_date { format_date(@_); } +END_OF_SUB + +$COMPILE{_parse_format} = __LINE__ . <<'END_OF_SUB'; +sub _parse_format { parse_format(@_) } +END_OF_SUB + + +$COMPILE{_parse_gmt_date} = __LINE__ . <<'END_OF_SUB'; +sub _parse_gmt_date { +# ---------------------------------------------------- +# attempts to turn a date string into a unix timestamp +# + my $in = shift || return timegm ( gmtime() ); + my ($sec, $min, $hour, $day, $mon, $year); + +# Handle + or - increments easily, just calculate current +# gmtime, and figure out desired offset and return. + if ($in =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { + my %mult = ( + 's' => 1, + 'm' => 60, + 'h' => 60*60, + 'd' => 60*60*24, + 'M' => 60*60*24*30, + 'y' => 60*60*24*365 + ); + my $gmtime = timegm( gmtime() ); + $gmtime = $gmtime + ($mult{$2} || 1) * $1; + return $gmtime; + } + +# Otherwise, we try and build a gmtime array, to pass +# to timegm. + if ( $in =~ s/(\d+):(\d+)(:(\d+))?\s*(am|pm)?//i ) { + ( $hour, $min, $sec ) = ( $1 || 0, $2 ||0, $4 || 0 ); + if ( ( $hour < 12 ) and ( lc($5) eq 'pm' ) ) { $hour += 12 } + if ( ( $hour == 12 ) and ( lc($5) eq 'am' ) ) { $hour = 0 } + } + +# Try and find either the long month or short month. + my $mo_regex = join("|", ( @MONTHS, @MONTHS_SH )); + if ($in =~ /($mo_regex)/i ) { + my $mostr = $1; + $mon = $MONTH_HASH{$mostr}; + $in =~ s/(\d+)?(st|nd|th)?\s*$mostr\s*(\d+)(st|nd|th)?//i; + if ( $1 > 31 ) { + $year = $1; + $day = $3; + } + else { + $day = $1 || $3; + if ( $day > 31 ) { + $year = $day; + $day = 0; + } + } + } + +# Try and get a four digit year. + if ($in =~ s/(\d\d\d\d)//) { + $year = $1; + } + +# Try and get dd/mm/yy format. + if ($in =~ s,(\d+)/(\d+)/(\d+),,o) { + $day = $1; + $mon = $2; + $year = $3; + } + +# If the word equals 'now', then use that. + my @local = gmtime(); + $local[5] += 1900; + $local[4]++; + if ($in =~ s/now//) { + ($sec, $min, $hour, $day, $mon, $year) = @local[ 0, 1, 2, 3, 4, 5 ]; + } + else { + $day ||= $local[3]; + $mon ||= $local[4]; + $year ||= $local[5]; + + if (!defined($hour)) { + $hour ||= $local[2]; + $min ||= $local[1]; + $sec ||= $local[0]; + } + } + +# Make sure we have a four digit year. + ($year < 99) and ($year += 1900); + +# Timelocal needs month in same format as localtime (i.e. indexed from 0). + return timegm ($sec, $min, $hour, $day, $mon - 1, $year); +} +END_OF_SUB + + +$COMPILE{_calc_my} = __LINE__ . <<'END_OF_SUB'; +sub _calc_my { +# ------------------------------------------------------------------- +# Calculates the gmtime of the month and year. +# + my $date = shift; + my ($sec, $min, $hour, $day, $mon, $year) = split /\0/, $date; + if ($RANGE_CHECK) { + ($mon > 11 or $mon < 0) and die "Month '$mon' out of range 0..1"; + ($day > 31 or $day < 1) and die "Day '$day' out of range 1..31"; + ($hour > 23 or $hour < 0) and die "Hour '$hour' out of range 0..23"; + ($min > 59 or $min < 0) and die "Minute '$min' out of range 0..59"; + ($sec > 59 or $sec < 0) and die "Second '$sec' out of range 0..59"; + } + my $guess = $^T; + my @guess = gmtime ($guess); + my $last = ''; + my $count = 0; + my $diff = 0; + +# Calc year offset. + while ($diff = $year - $guess[5]) { + if ($count++ > 255) { + warn "GT::Date - can't handle date: $date\n" if ($LOUD); + return 0; + } + $guess += $diff * (363 * DAY); + @guess = gmtime ($guess); + if ("@guess" eq $last) { + warn "GT::Date - can't handle date: $date\n" if ($LOUD); + return 0; + } + $last = "@guess"; + } +# Calc month offset. + while ($diff = $mon - $guess[4]) { + if ($count++ > 255) { + warn "GT::Date - can't handle date: $date\n" if ($LOUD); + return 0; + } + $guess += $diff * (27 * DAY); + @guess = gmtime ($guess); + if ("@guess" eq $last) { + warn "GT::Date - can't handle date: $date\n" if ($LOUD); + return 0; + } + $last = "@guess"; + } +# We only want the month/year aspect. + $guess[3]--; + $guess -= $guess[0] * SEC + $guess[1] * MIN + $guess[2] * HOUR + $guess[3] * DAY; + return $guess; +} +END_OF_SUB + +$COMPILE{_transform} = __LINE__ . <<'END_OF_SUB'; +sub _transform { +# ---------------------------------------------------- +# Transforms a date from one format to another, not called +# directly, accessed through cache. +# + my $key = shift; + my ($date, $orig, $new, @lang) = split /\0/, $key; + if (@lang != 38) { + die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang; + } + local @MONTHS = @lang[0 .. 11]; + local @DAYS = @lang[12 .. 18]; + local @MONTHS_SH = @lang[19 .. 30]; + local @DAYS_SH = @lang[31 .. 37]; + + my $time = parse_format ($date, $orig) or return; + return format_date ($time, $new); +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::Date - Common date parsing and manipulation routines + +=head1 SYNOPSIS + + use GT::Date qw/:all/; + my $date = date_get(); + my $next_week = date_add($date, 7); + my $is_bigger = date_is_greater($date, $next_week); + +=head1 DESCRIPTION + +GT::Date provides several functions useful in parsing dates, and +doing date manipulation. Under the hood, it uses Time::Local +code to transform a date into seconds for comparison and +mathematical operations. It also uses L to store +most of the complex work. + +No functions are exported by default. You can either specify +the functions you need in use, or use the tags ':all' or +':timelocal'. All will give you all functions, and timelocal +will give you functions found in Time::Local. + +GT::Date uses a package global $DATE_FMT which specifies +the format that dates should be returned in. You can change this using +the date_set_format() function. + +=head2 date_is_valid + +Returns 1 if the argument passed in is a valid date. It must first +be in the current date format, and then be a valid date. + +=head2 date_is_greater + +Returns 1 if argument 1 is greater then argument 2, otherwise 0. + +=head2 date_is_smaller + +Returns 1 if argument 1 is smaller then argument 2, otherwise 0. + +=head2 date_get date_get_gm + +Called with no arguments, returns the current date based on system +time. You can specify the date you want by passing in the seconds +since epoch (output of time()). + +=head2 date_comp + +Equivalent to arg1 <=> arg2. + +=head2 date_diff + +Returns number of days difference between arg1 - arg2. + +=head2 date_add date_add_gm + +Returns date derived from arg1 + arg2, where the second argument +can be either a date or number of days. + +=head2 date_sub date_sub_gm + +Returns date derived from arg1 - arg2, where the second argument +can be either a date or number of days. + +=head2 timegm + +Takes the returned array from gmtime() and returns a unix time +stamp. + +=head2 timlocal + +Takes the array returned by localtime() and returns a unix time +stamp. + +=head2 parse_format + +Takes a string and a date format and returns an array +ref of the first 7 arguments returned by localtime(). + +=head2 format_date + +Takes a localtime array, and a format string and returns a string +of the parsed format. + +=head2 Setting date format + +You can use date_set_format to change the format. You pass in a +format string. It is made up of: + + %yyyy% four digit year as in 1999 + %yy% two digit year as in 99 + %y% two digit year without leading 0 + %mmmm% long month name as in January + %mmm% short month name as in Jan + %mm% numerical month name as in 01 + %m% numerical month name without leading 0 as in 1 + %dddd% long day name as in Sunday + %ddd% short day name as in Sun + %dd% numerical date + %d% numerical date without leading 0 + %HH% two digit hour, 24 hour time + %H% one or two digit hour, 24 hour time + %hh% two digit hour, 12 hour time. 0 becomes 12. + %h% one or two digit hour, 12 hour time. 0 becomes 12. + %MM% two digit minute + %M% one or two digit minute (when would someone ever WANT this?) + %ss% two digit second + %s% one ot two digit second (when would someone ever WANT this?) + %tt% AM or PM (use with 12 hour time) + %o% + or - GMT offset + +Common formats include: + + %yyyy%-%mm%-%dd% 1999-12-25 + %dd%-%mmm%-%yyyy% 12-Dec-1999 + %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 + %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 + +or RFC822 mime mail format: + + %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800 + +or MySQL format: + + %yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02 + +The language used for month names and day names can be changed with +date_set_month(), date_set_days(), date_set_days_short() and +date_set_month_short(). + +=head2 Transforming between date formats. + +You can transform a date from one format to another with: + + date_transform ($date, $orig_fmt, $new_fmt); + +where $orig_fmt and $new_fmt are date format strings described above. + +=head2 Getting the GM offset. + +You can get the number of seconds between the system time and GM time +using: + + my $time = date_gmt_offset(); + +So if you are in Pacific time, it would return 25200 seconds (-0700 time zone). + +=head1 EXAMPLES + +Get todays date, the default format unless specified is yyyy-mm-dd. + + print date_get(); 2000-12-31 + +Get todays date in a different format: + + date_set_format('%ddd% %mmm% %dd% %yyyy%'); + print date_get(); Sat Dec 31 2000 + +Get the date from 1 week ago. + + # Long way + my $date1 = date_get(); + my $date2 = date_sub($date1, 7); + + or + + # Can pass in unix timestamp of date we want. + my $date = date_get (time - (7 * 86400)); + +Compare two dates. + + my $halloween = '2000-10-31'; + my $christmas = '2000-12-25'; + if (date_is_smaller($halloween, $christmas)) { + print "Halloween comes before christmas!"; + } + if (date_is_greater($christmas, $halloween)) { + print "Yup, christmas comes after halloween."; + } + my @dates = ($halloween, $christmas); + print "Dates in order: ", sort date_comp @dates; + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Date.pm,v 1.75 2005/04/04 22:21:23 brewt Exp $ + +=cut diff --git a/site/glist/lib/GT/Delay.pm b/site/glist/lib/GT/Delay.pm new file mode 100644 index 0000000..31ce8cb --- /dev/null +++ b/site/glist/lib/GT/Delay.pm @@ -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{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{foo}-E{bar}> - though C{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 diff --git a/site/glist/lib/GT/Dumper.pm b/site/glist/lib/GT/Dumper.pm new file mode 100644 index 0000000..d83375a --- /dev/null +++ b/site/glist/lib/GT/Dumper.pm @@ -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 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 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 would return: C<$VAR = 'foo'>. You can change and even omit +the assignment using the C 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 option. + +=item * sort + +The C 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 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 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 option is +ignored - it is treated as if a blank C 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 option. + +=head1 SEE ALSO + +L + +=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 diff --git a/site/glist/lib/GT/File/Diff.pm b/site/glist/lib/GT/File/Diff.pm new file mode 100644 index 0000000..6396a80 --- /dev/null +++ b/site/glist/lib/GT/File/Diff.pm @@ -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, +# 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; 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 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 to be as long as possible. In this case +I 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-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 and C 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. But actually, the LCS +is C: + + 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, +C, C, C, and C. + +=head2 C + +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 may be passed an optional third parameter; this is a CODE +reference to a key generation function. See L. + + @lcs = LCS( \@seq1, \@seq2, $keyGen ); + $lcsref = LCS( \@seq1, \@seq2, $keyGen ); + +Additional parameters, if any, will be passed to the key generation +routine. + +=head2 C + + @diffs = diff( \@seq1, \@seq2 ); + $diffs_ref = diff( \@seq1, \@seq2 ); + +C 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; each hunk +represents a contiguous section of items which should be added, +deleted, or replaced. The return value of C 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 at +position 0 of the first sequence should be deleted (C<->). The second +hunk says that the C at position 2 of the second sequence should +be inserted (C<+>). The third hunk says that the C at position 4 +of the first sequence should be removed and replaced with the C +from position 4 of the second sequence. The other two hunks similarly. + +C may be passed an optional third parameter; this is a CODE +reference to a key generation function. See L. + +Additional parameters, if any, will be passed to the key generation +routine. + +=head2 C + + @sdiffs = sdiff( \@seq1, \@seq2 ); + $sdiffs_ref = sdiff( \@seq1, \@seq2 ); + +C computes all necessary components to show two sequences +and their minimized differences side by side, just like the +Unix-utility I 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: Element unmodified, +C: Element changed) and the value of the old and new elements, to +be displayed side by side. + +An C 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 may be passed an optional third parameter; this is a CODE +reference to a key generation function. See L. + +Additional parameters, if any, will be passed to the key generation +routine. + +=head2 C + +C is the most general facility provided by this +module; C and C 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 +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 when arrow A is +pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens, +C will call the C 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 will advance that arrow and will +call the C or the C callback, depending on which arrow it +advanced. If both arrows point to elements that are not part of the LCS, then +C will advance one of them and call the appropriate +callback, but it is not specified which it will call. + +The arguments to C 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 will call the C callback when it advances +arrow B, if there is such a function; if not it will call C instead. +Similarly if arrow B finishes first. C 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 may be passed an optional fourth parameter; this is a +CODE reference to a key generation function. See L. + +Additional parameters, if any, will be passed to the key generation function. + +=head2 C + +C is an alternative to C. 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 occurring as deletions on one +side followed immediatly by an insertion on the other side. + +In addition to the +C, +C, and +C +callbacks supported by C, C supports +a C callback indicating that one element got C by another: + + traverse_sequences( \@seq1, \@seq2, + { MATCH => $callback_1, + DISCARD_A => $callback_2, + DISCARD_B => $callback_3, + CHANGE => $callback_4, + } ); + +If no C callback is specified, C +will map C events to C and C actions, +therefore resulting in a similar behaviour as C +with different order of events. + +C might be a bit slower than C, +noticable only while processing huge amounts of data. + +The C function of this module +is implemented as call to C. + +=head1 KEY GENERATION FUNCTIONS + +C, C, and C 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 , which is available at +ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st + +C and C were written by Mike Schilli +. + +The algorithm is that described in +I, +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; diff --git a/site/glist/lib/GT/File/Tools.pm b/site/glist/lib/GT/File/Tools.pm new file mode 100644 index 0000000..23a7190 --- /dev/null +++ b/site/glist/lib/GT/File/Tools.pm @@ -0,0 +1,1507 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::File::Tools +# Author : Scott Beck +# CVS Info : +# $Id: Tools.pm,v 1.61 2005/05/13 01:48:23 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Basic file tools +# + +package GT::File::Tools; +# ================================================================== + +use strict; +use vars qw/ + $VERSION + @EXPORT_OK + %EXPORT_TAGS + $MAX_DEPTH + $GLOBBING + $ERRORS + $MAX_READ + $DEBUG + $NO_CHDIR + $REGEX + $UNTAINT +/; +$REGEX = '^([^\0]+)$'; + +use bases 'GT::Base' => ''; + +use Cwd; +require Exporter; +use GT::AutoLoader; +$VERSION = sprintf "%d.%03d", q$Revision: 1.61 $ =~ /(\d+)\.(\d+)/; + +# Exporter variables +@EXPORT_OK = qw/ + copy + move + del + deldir + find + mkpath rmkdir + parsefile + basename + filename + dirname + expand +/; +%EXPORT_TAGS = ( all => \@EXPORT_OK ); +*import = \&Exporter::import; + +# Options +$MAX_DEPTH = 1000; +$GLOBBING = 0; +$NO_CHDIR = 0; +$MAX_READ = 1024 * 64; +$UNTAINT = 0; +$DEBUG = 0; +$ERRORS = { + UNLINK => "Could not unlink '%s': %s", + RMDIR => "Could not rmdir '%s': %s", + MOVE => "Could not move '%s' to '%s': %s", + RENAME => "Could not rename '%s' to '%s': %s", + SYMLINK => "Could not symlink '%s' to '%s': %s", + NOTAFILE => "File to copy, move, or del ('%s') is not a regular file", + NOTADIR => "Path passed to find ('%s') is not a directory", + TOODEEP => "Recursive find surpassed max depth. Last path was %s", + RECURSIVE => "Circular symlinks detected", + OPENDIR => "Could not open directory '%s': %s", + READOPEN => "Could not open '%s' for reading: %s", + WRITEOPEN => "Could not open '%s' for writing: %s" +}; + +$COMPILE{move} = __LINE__ . <<'END_OF_SUB'; +sub move { +# ---------------------------------------------------------------------------- + my $class = 'GT::File::Tools'; + + $class->fatal( BADARGS => "No arguments passed to move()" ) + unless @_; + + my $opts = ref $_[-1] eq 'HASH' ? pop : {}; + + my $to = pop; + $class->fatal( BADARGS => "No place to move files to specified for move()" ) + unless defined $to; + + my $globbing = delete $opts->{globbing}; + $globbing = $GLOBBING unless defined $globbing; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + my @files = @_; + @files = expand( @files ) if $globbing; + + $class->fatal( BADARGS => "No files to move" ) + unless @files; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } + unless defined $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + my %seen; + for my $from_file ( @files ) { + my $to_file = $to; + if ( !-d $to and $seen{$to}++ ) { + $class->fatal( + BADARGS => "Trying to move multiple files into one file" + ); + } + if ( -d $from_file ) { + $class->debug( "movedir $from_file, $to_file" ) if $DEBUG > 1; + movedir( + $from_file, $to_file, + { + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex, + } + ) or return; + next; + } + if ( -d $to_file ) { + $to_file = $to . '/' . basename( $from_file ); + } + if ($untaint) { + $to_file =~ $untaint_regex and $to_file = $1; + is_tainted($to_file) and die "bad file $to_file"; + $from_file =~ $untaint_regex and $from_file = $1; + is_tainted($from_file) and die "bad file $from_file"; + } + if ( -l $from_file ) { + my ( $link ) = _fix_symlink( $from_file ); + if ( !symlink $link, $to_file ) { + $error_handler->( SYMLINK => $from_file, $to_file, "$!" ) + or return; + } + if ( !unlink $from_file ) { + $error_handler->( UNLINK => $from_file, "$!" ) + or return; + } + next; + } + my ( $to_size_before, $to_mtime_before ) = ( stat( $to_file ) )[7, 9]; + my $from_size = -s $from_file; + $class->debug( "rename $from_file, $to_file" ) if $DEBUG > 1; + next if rename $from_file, $to_file; + my $err = "$!"; + my $errno = 0+$!; + +# Under NFS rename can work but still return an error, check for that + my ( $to_size_after, $to_mtime_after ) = ( stat( $to_file ) )[7, 9]; + if ( defined $from_size and -e $from_file ) { + if ( + defined $to_mtime_before and + ( + $to_size_before != $to_size_after or + $to_mtime_before != $to_mtime_after + ) and + $to_size_after == $from_size + ) + { + $class->debug( "rename over NFS worked" ) if $DEBUG > 1; + next; + } + } + + $class->debug( "copy $from_file, $to_file" ) if $DEBUG > 1; + next if copy( $from_file, $to_file, + { + preserve_all => 1, + max_depth => $max_depth, + error_handler => $error_handler, + untaint => $untaint, + untaint_regex => $untaint_regex, + } + ) and unlink $from_file; + +# Remove if a particial copy happened + if ( + !defined( $to_mtime_before ) or + $to_mtime_before != $to_mtime_after or + $to_size_before != $to_size_after + ) + { + unlink $to_file; + } + $error_handler->( RENAME => $from_file, $to_file, $err, $errno ) + or return; + } + return 1; +} +END_OF_SUB + +$COMPILE{movedir} = __LINE__ . <<'END_OF_SUB'; +sub movedir { +# ---------------------------------------------------------------------------- + my ( $from, $to, $opts ) = @_; + my $class = 'GT::File::Tools'; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } + unless defined $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + $from .= '/' unless $from =~ m,/\Z,; + $to .= '/' unless $to =~ m,/\Z,; + +# To move a directory inside an already existing directory + $to .= basename( $from ) if -d $to; + +# Try the easy way out first + return 1 if rename $from, $to; + + my $cwd; + if ( ( parsefile( $from ) )[2] ) { + $cwd = mycwd(); + $from = "$cwd/$from"; + } + if ( ( parsefile( $to ) )[2] ) { + $cwd ||= mycwd(); + $to = "$cwd/$to"; + } + if ($untaint) { + $to =~ $untaint_regex and $to = $1; + is_tainted($to) and die "bad file $to"; + $from =~ $untaint_regex and $from = $1; + is_tainted($from) and die "bad file $from"; + } + + return find( + $from, + sub { + my ( $path ) = @_; + if ( -l $path ) { + $path .= '/' if ( -d _ and $path !~ m,/\Z, ); + my ( $link, $relative ) = _fix_symlink( $path ); + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "link $link, $new_path" ) if $DEBUG > 1; + unless (-l $new_path) { + symlink $link, $new_path + or $error_handler->( SYMLINK => $link, $new_path, "$!" ) + or return; + } + _preserve( $path, $new_path, + set_owner => 1, + set_time => 1 + ); + unlink $path + or $error_handler->( UNLINK => $path, "$!" ) + or return; + return 1; + } + elsif ( -d $path ) { + $path .= '/' unless $path =~ m,/\Z,; + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "mkdir $new_path" ) if $DEBUG > 1; + unless (-d $new_path) { + mkdir $new_path, 0777 + or $error_handler->( MKDIR => $new_path, "$!" ) + or return; + } + _preserve( $path, $new_path, + set_perms => 1, + set_owner => 1, + set_time => 1 + ); + rmdir $path + or $error_handler->( RMDIR => $path, "$!" ) + or return; + } + elsif ( -f _ ) { + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "move $path, $new_path" ) if $DEBUG > 1; + move( $path, $new_path, + { + error_handler => $error_handler, + max_depth => $max_depth, + } + ) or $error_handler->( MOVE => $path, $new_path, "$!" ) + or return; + } + else { + $error_handler->( NOTAFILE => $path ) or return; + } + return 1; + }, + { + dirs_first => 1, + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex, + } + ); +} +END_OF_SUB + +$COMPILE{del} = __LINE__ . <<'END_OF_SUB'; +sub del { +# ---------------------------------------------------------------------------- + my $class = 'GT::File::Tools'; + my $opts = ref $_[-1] eq 'HASH' ? pop : {}; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my $globbing = delete $opts->{globbing}; + $globbing = $GLOBBING unless defined $globbing; + + my @files = @_; + @files = expand( @files ) if $globbing; + + $class->fatal( BADARGS => "No directories to delete" ) + unless @files; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + for my $path ( @files ) { + if ($untaint) { + $path =~ $untaint_regex and $path = $1; + is_tainted($path) and die "bad file $path"; + } + if ( -l $path ) { + $class->debug( "unlink $path" ) if $DEBUG > 1; + unlink $path + or $error_handler->( UNLINK => $path, "$!" ) + or return; + } + elsif ( -d $path ) { + $error_handler->( NOTAFILE => $path ) + or return; + } + else { + unlink $path + or $error_handler->( UNLINK => $path, "$!" ) + or return; + } + } + return 1; +} +END_OF_SUB + +$COMPILE{deldir} = __LINE__ . <<'END_OF_SUB'; +sub deldir { +# ---------------------------------------------------------------------------- + my $class = 'GT::File::Tools'; + my $opts = ref $_[-1] eq 'HASH' ? pop : {}; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my $globbing = delete $opts->{globbing}; + $globbing = $GLOBBING unless defined $globbing; + + my @dirs = @_; + @dirs = expand( @dirs ) if $globbing; + + $class->fatal( BADARGS => "No directories to delete" ) + unless @dirs; + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + for my $dir ( @dirs ) { + if ($untaint) { + $dir =~ $untaint_regex and $dir = $1; + is_tainted($dir) and die "bad file $dir"; + } + next unless -e $dir or -l $dir; + +# Try the easy way out first + next if rmdir $dir or unlink $dir; + + find( + $dir, + sub { + my ( $path ) = @_; + if ( -l $path ) { + $class->debug( "unlink $path" ) if $DEBUG > 1; + unlink $path + or $error_handler->( UNLINK => $path, "$!" ) + or return; + } + elsif ( -d $path ) { + $class->debug( "rmdir $path" ) if $DEBUG > 1; + rmdir $path + or $error_handler->( RMDIR => $path, "$!" ) + or return; + } + else { + $class->debug( "unlink $path" ) if $DEBUG > 1; + unlink $path + or $error_handler->( UNLINK => $path, "$!" ) + or return; + } + return 1; + }, + { + dirs_first => 0, + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex, + } + ); + } + return 1; +} +END_OF_SUB + +$COMPILE{copy} = __LINE__ . <<'END_OF_SUB'; +sub copy { +# ---------------------------------------------------------------------------- + my $class = 'GT::File::Tools'; + + $class->fatal( BADARGS => "No arguments passed to move()" ) + unless @_; + + my $opts = ref $_[-1] eq 'HASH' ? pop : {}; + my $to = pop; + $class->fatal( BADARGS => "No place to move files to specified for move()" ) + unless defined $to; + + my $globbing = delete $opts->{globbing}; + $globbing = $GLOBBING unless defined $globbing; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + my @files = @_; + @files = expand( @files ) if $globbing; + + $class->fatal( BADARGS => "No files to move" ) + unless @files; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } + unless defined $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my %preserve_opts = (set_perms => 1); + if ( delete $opts->{preserve_all} ) { + @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 ); + } + else { + $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms}; + @preserve_opts{qw/set_owner set_time/} = + ( + delete $opts->{set_owner}, + delete $opts->{set_time} + ); + } + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + my %seen; + for my $from_file ( @files ) { + my $to_file = $to; + if ( !-d $to_file and $seen{$to_file}++ ) { + $class->fatal( + BADARGS => "Trying to copy multiple files into one file $from_file => $to" + ); + } + if ( -d $from_file ) { + $class->debug( "copydir $from_file, $to_file" ) if $DEBUG > 1; + copydir( $from_file, $to_file, { + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex, + %preserve_opts + }); + next; + } + if ( -d $to_file ) { + $to_file = $to . '/' . basename( $from_file ); + } + if ($untaint) { + $to_file =~ $untaint_regex and $to_file = $1; + is_tainted($to_file) and die "bad file $to_file"; + + $from_file =~ $untaint_regex and $from_file = $1; + is_tainted($from_file) and die "bad file $from_file"; + } + + if ( -l $from_file ) { + my ( $link ) = _fix_symlink( $from_file ); + if ($untaint) { + $link =~ $untaint_regex and $link = $1; + is_tainted($link) and die "bad file $link"; + } + + if ( !symlink $link, $to_file ) { + $error_handler->( SYMLINK => $from_file, $to_file, "$!" ) + or return; + } + next; + } + + local( *FROM, *TO ); + $class->debug( "open $from_file" ) if $DEBUG > 1; + unless ( open FROM, "< $from_file" ) { + $error_handler->( READOPEN => $from_file, "$!" ) or return; + next; + } + $class->debug( "open $to_file" ) if $DEBUG > 1; + unless ( open TO, "> $to_file" ) { + $error_handler->( WRITEOPEN => $to_file, "$!" ) or return; + next; + } + binmode FROM or $class->fatal( BINMODE => "$!" ); + binmode TO or $class->fatal( BINMODE => "$!" ); + my $size = -s FROM; + $size = $MAX_READ if $size > $MAX_READ; + + while () { + my ( $ret, $buf ); + $ret = sysread FROM, $buf, $size; + $class->fatal( READ => "$!" ) + unless defined $ret; + last unless $ret; + $ret = syswrite TO, $buf, length $buf; + $class->fatal( WRITE => "$!" ) + unless defined $ret; + } + + close FROM; + close TO; + +# Set permissions, mtime, and owner + _preserve( $from_file, $to_file, %preserve_opts ); + + } + return 1; +} +END_OF_SUB + +$COMPILE{copydir} = __LINE__ . <<'END_OF_SUB'; +sub copydir { +# ---------------------------------------------------------------------------- + my ( $from, $to, $opts ) = @_; + my $class = 'GT::File::Tools'; + + $class->fatal( BADARGS => "No from directory specified" ) + unless defined $from; + $class->fatal( BADARGS => "From file specified must be a directory" ) + unless -d $from; + $class->fatal( BADARGS => "No to directory specified" ) + unless defined $from; + my $error_handler = delete $opts->{error_handler}; + + $error_handler = sub { $class->warn( @_ ); 1 } + unless defined $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my %preserve_opts = (set_perms => 1); + if ( delete $opts->{preserve_all} ) { + @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 ); + } + else { + $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms}; + @preserve_opts{qw/set_owner set_time/} = + ( + delete $opts->{set_owner}, + delete $opts->{set_time} + ); + } + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + $from .= '/' unless $from =~ m,/\Z,; + $to .= '/' unless $to =~ m,/\Z,; + +# To move a directory inside an already existing directory + $to .= basename( $from ) if -d $to; + + my $cwd; + if ( ( parsefile( $from ) )[2] ) { + $cwd = mycwd(); + if ($untaint) { + $cwd =~ $untaint_regex and $cwd = $1; + is_tainted($cwd) and die "bad file $cwd"; + } + + $from = "$cwd/$from"; + } + if ( ( parsefile( $to ) )[2] ) { + $cwd ||= mycwd(); + $to = "$cwd/$to"; + } + if ($untaint) { + $to =~ $untaint_regex and $to = $1; + is_tainted($to) and die "bad file $to"; + $from =~ $untaint_regex and $from = $1; + is_tainted($from) and die "bad file $from"; + } + $from =~ s{/\Z}{}; + $to =~ s{/\Z}{}; + + return find( + $from, + sub { + my ( $path ) = @_; + if ( -l $path ) { + $path .= '/' if ( -d _ and $path !~ m,/\Z, ); + my ( $link, $relative ) = _fix_symlink( $path ); + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "link $link, $new_path" ) if $DEBUG > 1; + unless (-l $new_path) { + if ($untaint) { + $link =~ $untaint_regex and $link = $1; + is_tainted($link) and die "bad file $link"; + } + + symlink $link, $new_path + or $error_handler->( SYMLINK => $link, $new_path, "$!" ) + or return; + } + _preserve( $path, $new_path, %preserve_opts ); + return 1; + } + elsif ( -d $path ) { + $path .= '/' unless $path =~ m,/\Z,; + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "mkdir $new_path" ) if $DEBUG > 1; + unless (-d $new_path) { + mkdir $new_path, 0777 + or $error_handler->( MKDIR => $new_path, "$!" ) + or return; + } + _preserve( $path, $new_path, %preserve_opts ); + } + elsif ( -f $path ) { + $from =~ s{/\Z}{}; + $to =~ s{/\Z}{}; + + ( my $new_path = $path ) =~ s!\A\Q$from!$to!; + $class->debug( "copy $path, $new_path" ) if $DEBUG > 1; + copy( $path, $new_path, + { + %preserve_opts, + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex + } + ) + or $error_handler->( MOVE => $path, $new_path, "$GT::File::Tools::error" ) + or return; +# copy() will handle setting permission and such + } + else { + $error_handler->( NOTAFILE => $path ) + or return; + } + return 1; + }, + { + dirs_first => 1, + error_handler => $error_handler, + max_depth => $max_depth, + untaint => $untaint, + untaint_regex => $untaint_regex, + } + ); +} +END_OF_SUB + +$COMPILE{filename} = __LINE__ . <<'END_OF_SUB'; +sub filename { +# ----------------------------------------------------------------------------- +# Deprecated name for basename +# + goto &basename; + +} +END_OF_SUB + +sub basename { +# ----------------------------------------------------------------------------- + return ( parsefile( $_[0] ) )[1]; +} + +sub dirname { +# ---------------------------------------------------------------------------- + return ( parsefile( $_[0] ) )[0]; +} + +$COMPILE{parsefile} = __LINE__ . <<'END_OF_SUB'; +sub parsefile { +# ---------------------------------------------------------------------------- + my ( $in ) = @_; + my ( @path, @normal, $relative, $win32 ); + if ( $^O eq 'MSWin32' ) { + $win32 = $1 if $in =~ s/\A(\w:)//; + @path = split m|[/\\]|, $in; + $relative = 1 unless $in =~ m,\A[/\\],; + } + else { + @path = split m|/|, $in; + $relative = 1 unless $in =~ m,\A/,; + } + my $start = 0; + for ( @path ) { + if ( $_ eq '.' or !length ) { next } + elsif ( $_ eq '..' ) { $start-- } + else { $start++ } + + if ( !$relative and $start < 0 and $_ eq '..' ) { next } + elsif ( $start < 0 and $_ eq '..' ) { push @normal, ".." } + elsif ( $start >= 0 and $_ eq '..' ) { pop @normal } + else { push @normal, $_ } + } + my $file = pop @normal; + my $new_path = join "/", @normal; + $new_path = $relative ? "./$new_path" : "/$new_path"; + $new_path = "$win32$new_path" if $win32; + if ($new_path =~ /$REGEX/) { + $new_path = $1 ; + } + else { + die "Bad path $new_path"; + } + if (length $file) { + if ($file =~ /$REGEX/) { + $file = $1 ; + } + else { + die "Bad path $file"; + } + } + + return ( $new_path, $file, $relative ); +} +END_OF_SUB + + +$COMPILE{mkpath} = __LINE__ . <<'END_OF_SUB'; +sub mkpath { + my ($full_path, $perms, $opts) = @_; + my $class = 'GT::File::Tools'; + $opts ||= {}; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + my ($path, $target, $is_relative) = parsefile($full_path); + GT::File::Tools->fatal(BADARGS => 'You cannot pass a relative path to mkpath') + if $is_relative; + my $cwd = mycwd(); + if ($untaint) { + $cwd =~ $untaint_regex and $cwd = $1; + is_tainted($cwd) and die "bad file $cwd"; + } + my @tomake = (split(m|/|, $path), $target); + my $err = sub { + my $bang = 0+$!; + chdir $cwd; + $! = $bang; + $class->warn(@_) if @_; + return; + }; + + # Find the deepest directory that exists, chdir into it, then mkdir all + # remaining paths from that point on, chdir()ing, for performance reasons, + # into each path as it is created. This is necessary as permissions on + # some OSes (Windows, and potentially unix systems with advanced + # permissions) can have a path such as: + # /foo/bar + # where -e '/foo' is 0, but -e '/foo/bar' is 1 + + my $start = '/'; + my @subpath; # /foo/bar/baz -> ('/foo/bar/baz/', '/foo/bar/', '/foo/', '/') + for (reverse 0 .. $#tomake) { + push @subpath, join '/', @tomake[0 .. $_], ''; + } + SUBPATH: for my $i (0 .. $#subpath) { + my $path = $subpath[$i]; + + if ($untaint) { + $path =~ $untaint_regex and $path = $1; + is_tainted($path) and die "bad file $_"; + } + + if (-d $path) { + return 1 if $i == 0; # The first path is the target + $start = $path; + splice @tomake, 0, -$i; + last SUBPATH; + } + } + + chdir $start or return $err->("chdir: $!"); + + for (@tomake) { + next unless length; + if ($untaint) { + $_ =~ $untaint_regex and $_ = $1; + is_tainted($_) and die "bad file $_"; + } + if (!-d $_) { + mkdir $_, 0777 or return $err->("mkdir $_: $!"); + if (defined $perms) { + chmod $perms, $_ or return $err->("chmod: $!"); + } + } + chdir $_ or return $err->("chdir: $!"); + } + chdir $cwd or return $err->("chdir $cwd: $!"); + return 1; +} +END_OF_SUB + +$COMPILE{rmkdir} = __LINE__ . <<'END_OF_SUB'; +# goto &foo didn't call AUTOLOAD until 5.005_03: +sub rmkdir { if ($] >= 5.005_03) { goto &mkpath } else { &mkpath } } +END_OF_SUB + +$COMPILE{find} = __LINE__ . <<'END_OF_SUB'; +sub find { +# ---------------------------------------------------------------------------- + my $class = 'GT::File::Tools'; + + $class->fatal( BADARGS => "No arguments passed to find()" ) + unless @_; + + my $opts = ref $_[-1] eq 'HASH' ? pop : {}; + my $callback = pop; + + $class->fatal( + BADARGS => "Argument after files list must be a code reference" + ) unless ref $callback eq 'CODE'; + + my $globbing = delete $opts->{globbing}; + $globbing = $GLOBBING unless defined $globbing; + + my @files = @_; + @files = expand( @files ) if $globbing; + + $class->fatal( BADARGS => "No files to find" ) + unless @files; + + my $error_handler = delete $opts->{error_handler}; + $error_handler = sub { $class->warn( @_ ); 1 } + unless defined $error_handler; + + $class->fatal( + BADARGS => "error_handler option must be a code reference" + ) unless ref $error_handler eq 'CODE'; + + my $no_chdir = delete $opts->{no_chdir}; + $no_chdir = $NO_CHDIR unless defined $no_chdir; + + my $dirs_first = delete $opts->{dirs_first}; + $dirs_first = 1 unless defined $dirs_first; + + my $files_only = delete $opts->{files_only}; + $files_only = 0 unless defined $files_only; + + my $dirs_only = delete $opts->{dirs_only}; + $dirs_only = 0 unless defined $dirs_only; + + my $untaint = delete $opts->{untaint}; + $untaint = $UNTAINT unless defined $untaint; + + my $untaint_regex = delete $opts->{untaint_regex}; + $untaint_regex = $REGEX unless defined $untaint_regex; + + my $max_depth = delete $opts->{max_depth}; + $max_depth = $MAX_DEPTH unless defined $max_depth; + + $class->fatal( + BADARGS => "You may only specify one of files_only or dirs_only" + ) if $files_only and $dirs_only; + + $class->fatal( + BADARGS => "Unknown option " . ( join ", ", keys %$opts ) + ) if keys %$opts; + + for my $path ( @files ) { + if ($untaint) { + $path =~ $untaint_regex and $path = $1; + is_tainted($path) and die "bad file $path"; + } + + next unless -e $path; + + unless ( -d _ ) { + $error_handler->( NOTADIR => $path ) or return; + next; + } + + my $relative = ( parsefile( $path ) )[2]; + my $cwd; + if ( !$no_chdir or $relative ) { + $cwd = mycwd(); + if ($untaint) { + $cwd =~ $untaint_regex and $cwd = $1; + is_tainted($cwd) and die "bad file $cwd"; + } + } + if ( $relative ) { + $path = "$cwd/$path"; + } + $class->debug( "find $path" ) if $DEBUG > 1; + eval { + _find( $path, $callback, { + error_handler => $error_handler, + dirs_first => $dirs_first, + files_only => $files_only, + max_depth => $max_depth, + no_chdir => $no_chdir, + untaint => $untaint, + untaint_regex => $untaint_regex, + dirs_only => $dirs_only + }) or do { + chdir $cwd; + return; + }; + }; + chdir $cwd unless $no_chdir; + die "$@\n" if $@; + } + return 1; +} +END_OF_SUB + +sub mycwd { getcwd || cwd || die "Could not get cwd; tried getcwd and cwd" } + +$COMPILE{_find} = __LINE__ . <<'END_OF_SUB'; +sub _find { +# ---------------------------------------------------------------------------- +# This is so we can initialize from variable and cleanup in the main find +# function. +# + my ( $path, $callback, $opts ) = @_; + my $error_handler = $opts->{error_handler}; + local *DIR; + if ( $opts->{dirs_first} and !$opts->{files_only} ) { + $callback->( $path ) or return; + } + my $refs = 0; + my $depth = 0; + my $opened; + if ( $opts->{no_chdir} ) { + $opened = opendir DIR, $path; + } + else { + if ( chdir $path ) { + $opened = opendir DIR, "."; + } + else { + $error_handler->( CHDIR => $path ) + or return; + } + } + if ( $opened ) { + my @files = + map { s,/\Z,,; $opts->{no_chdir} ? "$path/$_" : $_ } + grep { $_ ne '.' and $_ ne '..' } readdir DIR; + closedir DIR; + for ( my $i = 0; $i < @files; $i++ ) { + my $file = $files[$i]; + + if ( ref $file ) { + if ($opts->{untaint}) { + $$file =~ $opts->{untaint_regex} and $$file = $1; + is_tainted($$file) and die "bad file $$file"; + } + if ( !$opts->{dirs_first} and !$opts->{files_only} ) { + $callback->( $$file ) or return; + } + $depth-- if $opts->{max_depth}; + unless ( $opts->{no_chdir} ) { + chdir ".."; + substr( $path, rindex($path, "/") ) = "" + unless $opts->{no_chdir}; + } + next; + } + if ($opts->{untaint}) { + $file =~ $opts->{untaint_regex} and $file = $1; + is_tainted($$file) and die "bad file $$file"; + } + + if ( $opts->{max_depth} and $depth > $opts->{max_depth} ) { + GT::File::Tools->fatal( 'TOODEEP' ); + } + my $is_sym = -l $file; + my $is_dir = -d $file; + if ( $opts->{dirs_only} ) { + next unless $is_dir; + } + if ($is_sym) { + $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return; + } + elsif ( $is_dir ) { + if ( $opts->{dirs_first} and !$opts->{files_only} ) { + $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return; + } + local *DIR; + $depth++; + my @new_files; + if ( $opts->{no_chdir} ) { + if ( opendir DIR, $file ) { + @new_files = + map { s,/\Z,,; "$file/$_" } + grep { $_ ne '.' and $_ ne '..' } readdir DIR; + closedir DIR; + } + else { + $error_handler->( OPENDIR => $file ) or return; + } + } + else { + my $opened; + if ( chdir $file ) { + $opened = opendir DIR, "."; + } + else { + $error_handler->( CHDIR => $file ) + or return; + } + if ( $opened ) { + @new_files = map { s,/\Z,,; $_ } grep { $_ ne '.' and $_ ne '..' } readdir DIR; + closedir DIR; + } + else { + $error_handler->( OPENDIR => $file ) or return; + } + $path .= '/' . $file; + } + splice @files, $i + 1, 0, @new_files, ( $opts->{no_chdir} ? \$file : \$path ); + } + else { + next unless -e _; + $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return; + } + } + } + else { + $error_handler->( OPENDIR => $path ) or return; + } + if ( !$opts->{dirs_first} and !$opts->{files_only} ) { + $callback->( $path ) or return; + } + return 1; +} +END_OF_SUB + +$COMPILE{_fix_symlink} = __LINE__ . <<'END_OF_SUB'; +sub _fix_symlink { +# ---------------------------------------------------------------------------- +# Tries to get the full path to what a symlink is pointing to. Returns the +# path (full or relative) and a value that is true if the path is relative and +# false otherwise. +# + my ( $path ) = @_; + my $link = readlink $path; + my ( $relative1, $relative2 ); + ( undef, undef, $relative1 ) = parsefile( $link ); + ( undef, undef, $relative2 ) = parsefile( $path ); + if ( $relative1 and !$relative2 ) { + $relative1 = 0; + $link = dirname( $path ) . '/' . $link; + } + return ( $link, $relative1 ); +} +END_OF_SUB + +$COMPILE{_preserve} = __LINE__ . <<'END_OF_SUB'; +sub _preserve { +# ---------------------------------------------------------------------------- +# Set permissions, owner, mtime given file from, file to, and options: +# set_time +# set_owner +# set_perms +# + my ( $from, $to, %opts ) = @_; + my $class = 'GT::File::Tools'; + + my ( $mode, $uid, $gid, $mtime ); + if ( $opts{set_time} or $opts{set_owner} or $opts{set_perms} ) { + ( $mode, $uid, $gid, $mtime ) = (stat($from))[2, 4, 5, 9]; + } + if ( $opts{set_time} ) { + utime time, $mtime, $to; + } + + if ( $opts{set_owner} ) { + chown $uid, $gid, $to + if ( $> == 0 and $^O ne "MaxOS" and $^O ne "MSWin32" ); + } + + if ( $opts{set_perms} and !-l $to ) { + chmod $mode, $to or return $class->warn( 'CHMOD', $to, "$!" ); + } +} +END_OF_SUB + +$COMPILE{expand} = __LINE__ . <<'END_OF_SUB'; +sub expand { +# ---------------------------------------------------------------------------- +# Implement globbing for files. Perl's glob function has issues. +# + my $class = 'GT::File::Tools'; + my ( @files ) = @_; + my (@ret, $cwd); + for ( @files ) { + my ( $dirname, $filename, $relative ) = parsefile( $_ ); + if ($relative) { + $cwd ||= mycwd(); + ($dirname, $filename) = parsefile( "$cwd/$_" ); + } + if ( + index( $filename, '*' ) == -1 and + index( $filename, '?' ) == -1 + ) + { + push @ret, "$dirname/$filename"; + next; + } + $filename = quotemeta $filename; + $filename =~ s[(^|\G|[^\\])((?:\\{4})*)\\(\\\\)?(\\(?!\\)|[?*])]{ + $1 . ('\\' x (length($2) / 2)) . ($3 ? "\\$4" : $4 eq '*' ? '.*' : $4 eq '?' ? '.' : '\\') + }eg; + local *DIR; + opendir DIR, $dirname + or $class->fatal( OPENDIR => $dirname, "$!" ); + push @ret, map "$dirname/$_", grep { /\A$filename\Z/ and $_ ne '.' and $_ ne '..' } readdir DIR; + closedir DIR; + } + return @ret; +} +END_OF_SUB + + +sub is_tainted { return ! eval { my $no_warn = join('',@_), kill 0; 1; } } + +1; + +__END__ + +=head1 NAME + +GT::File::Tools - Export tools for dealing with files + +=head1 SYNOPSIS + + use GT::File::Tools qw/:all/; + + # Find all files in a users home directory. + find "/home/user", sub { print shift }; + + # Rename a file1 to file2. + move "file1", "file2"; + + # Remove a list of files. + del @files; + + # Remove a users home directory + deldir "/home/foo"; + + # Copy a file + copy "file1", "file2"; + + # Recursively copy a directory. + copy "/home/user", "/home/user.bak"; + + # Recursively make a directory. + mkpath "/home/user/www/cgi-bin", 0755; + + # Parse a filename into directory, file and is_relative components + my ($dir, $file, $is_rel) = parsefile("/home/foo/file.txt"); + + # Get the file portion of a filename + my $file = basename("/home/foo/file.txt"); + + # Get the directory portion of a filename. + my $dir = dirname("/home/foo/file.txt"); + + # Use shell like expansion to get a list of absolute files. + my @src = expand("*.c", "*.h"); + +=head1 DESCRIPTION + +GT::File::Tools is designed to export requested functions into your namespace. +These function perform various file operations. + +=head1 FUNCTIONS + +GT::File::Tools exports functions to your namespace. Here is a list of the +functions you can request to be exported. + +=head2 find + +C takes three parameters: directory to search in, callback to run for +each file and/or directory found, and a hash ref of options. B: this is +the opposite order of File::Find's find() function! The following options +can be passed set: + +=over 4 + +=item globbing + +Expand filenames in the same way as the unix shell: + + find("/home/a*", sub { print shift; }, { globbing => 1 }); + +would fine all home directories starting with the letter a. This option is +off by default. + +=item error_handler + +A code ref that is run whenever find encounters an error. If the callback +returns 0, find will stop immediately, otherwise find will continue +searching (default). + +=item no_chdir + +By default, find will chdir into the directories it is searching as +this results in a dramatic performance improvement. Upon completion, find +will chdir back to the original directory. This behavior is on by default. + +=item dirs_first + +This option controls the order find traverses. It defaults on, and means +find will go down directories first before looking at files. This is +essential for recursively deleting a directory. + +=item files_only + +This option tells find to run the callback only for each file found +and not for each directory. Off by default. + +=item dirs_only + +This option tells find to run the callback only for each directory found +and not for each file. Off by default. + +=item max_depth + +Defaults to 1000, this option controls how deep a directory structure find +will traverse. Meant mainly as a safety, and should not need to be adjusted. + +=back + +=head2 move + +C has the same syntax as the system mv command: + + move 'file', 'file2'; + move 'file1', 'file2', 'dir'; + move 'file1', 'file2', 'dir3', 'dir'; + move '*.c', 'dir', { globbing => 1 }; + +The only difference is the last argument can be a hash ref of options. The +following options are allowed: + +=over 4 + +=item globbing + +=item error_handler + +=item max_depth + +=back + +=head2 del + +C has the same syntax as the rm system command, but it can not remove +directories. Use C below to recursively remove files. + + del 'file1'; + del '*.c', { globbing => 1 }; + del 'a', 'b', 'c'; + +It takes a list of files or directories to delete, and an optional hash ref +of options. The following options are allowed: + +=over 4 + +=item error_handler + +=item globbing + +=back + +=head2 deldir + +C is similiar to C, but allows recursive deletes of directories: + + deldir 'file1'; + deldir 'dir11', 'dir2', 'dir3'; + deldir '/home/a*', { globbing => 1 }; + +It takes a list of files and/or directories to remove, and an optional hash ref +of options. The following options are allowed: + +=over 4 + +=item error_handler + +=item globbing + +=item max_depth + +=back + +=head2 copy + +C is similiar to the system cp command: + + copy 'file1', 'file2'; + copy 'file1', 'file2', 'file3', 'dir1'; + copy '*.c', '/usr/local/src', { globbing => 1 }; + copy + +It copies a source file to a destination file or directory. You can also +specify multiple source files, and copy them into a single directory. The +last argument should be a hash ref of options: + +=over 4 + +=item set_perms + +This option will preserve permissions. i.e.: if the original file is set 755, +the copy will also be set 755. It defaults on. + +=item set_owner + +This option will preserver file ownership. Note: you must be root to be able +to change ownerhsip of a file. This defaults off. + +=item set_time + +This option will preserve file modification time. + +=item preserve_all + +This option sets set_perms, set_owner and set_time on. + +=item error_handler + +=item globbing + +=item max_depth + +=back + +=head2 mkpath + +C recursively makes a directory. It takes the same arguments as +perl's mkdir(): + + mkpath("/home/alex/create/these/dirs", 0755) or die "Can't mkpath: $!"; + +For compatibility with older module versions, rmkdir() is an alias for +mkpath(). + +=head2 parsefile + +This function takes any type of filename (relative, fullpath, etc) and +returns the inputs directory, file, and whether it is a relative path or +not. For example: + + my ($directory, $file, $is_relative) = parsefile("../foo/bar.txt"); + +=head2 dirname + +Returns the directory portion of a filename. + +=head2 basename + +Returns the last portion of a filename (typically, the filename itself without +any leading directory). A deprecated C alias for basename() also +exists. + +=head2 expand + +Uses shell like expansion to expand a list of filenames to full paths. For +example: + + my @source = expand("*.c", "*.h"); + my @homedirs = expand("/home/*"); + +If you pass in relative paths, expand always returns absolute paths of +expanded files. B: this does not actually go to the shell. + +=head1 SEE ALSO + +This module depends on perl's Cwd module for getting the current working +directory. It also uses GT::AutoLoader to load on demand functions. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Tools.pm,v 1.61 2005/05/13 01:48:23 jagerman Exp $ + +=cut + diff --git a/site/glist/lib/GT/FileMan.pm b/site/glist/lib/GT/FileMan.pm new file mode 100644 index 0000000..306635e --- /dev/null +++ b/site/glist/lib/GT/FileMan.pm @@ -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 "Invalid action or command is disable : $action !"; + } +} + +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') || ""; + $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! + A fatal error has occured:

      $msg

      Please enable debugging in setup for more details.

      \n + !; + if ($DEBUG) { + print base_env(); + } +} + +sub base_env { +# -------------------------------------------------------------------- +# Return HTML formatted environment for error messages. +# + my $info = '
      ';
      +
      +# Stack trace.
      +    my $i = 0;
      +    $info .= "Stack Trace\n======================================\n";
      +    $info .= GT::Base::stack_trace('FileMan', 1, 1);
      +    $info .= "\n\n";
      +
      +    $info .= "System Information\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  .= "ENVIRONMENT\n======================================\n";
      +    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
      +    $info .= "
      "; + 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; diff --git a/site/glist/lib/GT/FileMan/Commands.pm b/site/glist/lib/GT/FileMan/Commands.pm new file mode 100644 index 0000000..794d980 --- /dev/null +++ b/site/glist/lib/GT/FileMan/Commands.pm @@ -0,0 +1,3115 @@ +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::FileMan::Commands +# CVS Info : +# $Id: Commands.pm,v 1.267 2005/04/11 17:24:03 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::FileMan::Commands; +# =============================================================== + use strict; + use GT::TempFile; + use GT::Base qw/:persist/; + use vars qw/$ICONS $READ_SIZE %LANGUAGE/; + use GT::AutoLoader; + use GT::File::Tools qw/:all/; + +# Our nasty language hash. + %LANGUAGE = ( + UPLOAD_MODE => "File %s was successfully uploaded in %s mode.", + MSG_LOG_OFF => "Please enter username and password to login.", + MSG_MULTI_UPLOAD => "%s files have been successfully uploaded.", + MSG_CHMOD_CHANGED => "Permissions on %s file(s) have been updated successfully.", + MSG_SEACH_FOUND => "Your search found %s results.", + MSG_REPLA_FOUND => "Your search and replace updated %s files in %s", + MSG_SEACH_NOTFOUND => "Your search did not produce any results.", + MSG_FILE_EDITING => "%s %s file ...(size %s bytes)-
      Download", + MSG_FILE_CREATED => "%s has been created.", + MSG_FILE_EDITED => "Changes to %s have been saved.", + MSG_DIR_CREATED => "%s directory has been created.", + MSG_PREFERENCES => "Your options have been saved.", + MSG_UNCOMPRESS => "%s file has been unarchived.", + MSG_TAR_CANCEL => "Creation of tar file has been cancelled.", + MSG_TAR_CREATED => "Tar file %s has been created.", + MSG_COPIED => " %s selected file/directory(s) have been copied (%s can not be copied).", + MSG_MOVED => " %s selected file/directory(s) have been moved (%s can not be moved).", + MSG_DEL_SUCC => "%s files and %s directories have been removed.", + MSG_DEL_CURR => "You've removed the directory: %s", + MSG_DEL_ALL => "You've removed the directory, and all contents recursively.", + MSG_DEL_SKIP => "You've skiped the directory :%s", + MSG_DEL_CANC => "You've cancelled deleting the directory", + MSG_DEL_ALL_SUCC => "All child dirs and files on the selected directorys has been removed. ", + MSG_CONTINUE => " click here to continue.", + MSG_PWD_CHANGED => "Your password was changed. ", + MSG_DEMO => "Disabled in Demo.", + MSG_USER_ADDED => "%s was added successfully.", + MSG_USER_DELETED => "%s was deleted successfully.", + MSG_USER_RMALL => "Users were deleted sucessfully.", + ERR_DEL => "Can not remove file(s)", + ERR_CHMOD => "Can not change mode ", + ERR_FILE_OPEN => "Can not open file: %s", + ERR_FILE_EMPTY => "File %s is empty.", + ERR_FILE_EXISTS => "File %s exists.", + ERR_FILE_NOT_EXISTS => "File %s does not exist.", + ERR_FILE_PERM => " Sorry, but we don't have write access to the htaccess files: '%s' and '%s'", + ERR_FILE_PEM => "The %s directory is not writeable.", + ERR_NOT_TEXT_FILE => "File %s is not a text file.", + ERR_DIR_NOT_EXISTS => "Directory %s does not exist.", + ERR_DIR_PEM => "The %s is not writeable.", + ERR_DIR_PERM => "Please check permission.", + ERR_NOT_ISFILE => "%s is a directory.", + ERR_TMP_FILE => "Can not open temp file.", + ERR_FREE_SPC => "Upload: Not enough free space to upload that file.", + ERR_RM_FILE => "Unable to remove file: %s. Reason: %s", + ERR_UPLOAD => "Unable to upload file: %s. Reason: %s.", + ERR_FILE_SAVE => "Cannot save file %s. Check permissions.", + ERR_DIR_EXISTS => "Directory %s already exists.", + ERR_NAME => "Illegal Characters in Directory. Please use letters, numbers, - and _ only.", + ERR_FILE_NAME1 => "No double .. allowed in file names.", + ERR_FILE_NAME2 => "No leading . in file names.", + ERR_READ_DIR => "Can not open dir: %s. Reason: %s", + ERR_DIR_DEEP => "Directory level too deep.", + ERR_DISK_SPACE => "Not enough space to save it (free space is %s kb)", + ERR_UNCOMPRESS => "Select files or directories before to uncompress.", + ERR_TAR => "Error: %s.", + ERR_TAR_NOT_EXISTS => "Can not create a tar file: %s", + ERR_TAR_PEM => "Can not create a tar file %s. Check permission.", + ERR_DOWNLOAD => "You selected a directory !", + ERR_LOGIN => "Invalid Username and Password.", + ERR_INVALID => "Input value has invalid characters : %s ", + ERR_NOT_FILE => "The %s is not a file", + ERR_OLD_PASSWORD => "Invalid Old password", + ERR_NEW_PASSWORD => "New password must be more than 3 character", + ERR_OPEN_FILE => "Can not open %s file, reason: %s", + ERR_WRITEABLE => "Can not save %s file, reason: %s", + ERR_NO_AZIP => "Please install the Archive::Zip library which is required.", + ERR_NO_GZIP => "Please install the Compress::Zlib library which is required.", + COBALT_NOREMOTE => "FileMan is not currently running under server authentication!", + ERR_VERSION => "This action does not support for your current version!", + ERR_PRINT => "Please select the files which are required text or image files", + PRINT_NEXT => "Print Next", + COBALT_NOUSER => "Unable to lookup user '%s'", + COBALT_BADUID => "Invalid user '%s' (%s)", + COBALT_CANTSU => "Can't switch to user '%s' (%s,%s). Reason: '%s'", + COBALT_BADDIR => "Invalid home directory '%s'. It does not look like a standard Raq director.", + COBALT_BADGROUP => "This program is restricted to site administrators only. You must be in the site administer group in order to use this." + ); + +# Mapping of image name to icon files. + $ICONS = { + 'gif jpg jpeg bmp' => ['image2.gif' => 'Image File'], + 'txt' => ['text.gif' => 'Text File'], + 'cgi pl pm' => ['text.gif' => 'Script File'], + 'zip gz tar' => ['compressed.gif' => 'Compressed File'], + 'htm html shtm shtml' => ['ie.gif' => 'Html File'], + 'wav au mid mod mp3' => ['sound.gif' => 'Sound File'], + 'exe' => ['binary.gif' => 'Binary File'], + 'doc' => ['doc.gif' => 'MS Word'], + 'xls' => ['xls.gif' => 'MS Excel'], + 'pdf' => ['pdf.gif' => 'Adobe Acrobat'], + 'unknown' => ['unknown.gif' => ''], + }; + +# How large a chunk should we read into memory at once. + $READ_SIZE = 500000; + +sub DESTROY {} + +$COMPILE{cmd_main_display} = __LINE__ . <<'END_OF_SUB'; +sub cmd_main_display { +# ------------------------------------------------------------------ +# Display main page +# + my ($self, $args, $type) = @_; + +# Load user list from .htpassword if it exists + if ($args->{show_passwd} or $self->{cgi}->{show_passwd}) { + $self->{url_opts} .= ';show_passwd=1' if ($self->{url_opts} !~ /show_passwd/); + my $htpasswd = $self->load_htpasswd(); + foreach (keys %$htpasswd) { + $args->{$_} ||= $htpasswd->{$_}; + } + } + $self->list_files(); + $self->{cgi}->{cmd_do} = 'cmd_command' if ($type); + $self->page('main.html', $args); +} +END_OF_SUB + +$COMPILE{load_htpasswd} = __LINE__ . <<'END_OF_SUB'; +sub load_htpasswd { + my $self = shift; + my $pass_path = $self->{in}->cookie('def_passwd_dir'); + + my ($htpasswd, $exist, $delete_list); + if (!$self->{cfg}->{passwd_dir_level} and !$pass_path =~ /^$self->{cfg}->{root_dir}/) { + print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'def_passwd_dir', -value => '0', -expires => '+5y')]); + $pass_path = ''; + } + + if ($pass_path) { # create .htaccess and .htpasswd in Password directory + my $file_name = $self->_safe_dir(); + $file_name =~ s/[\/ \:]/\_/g; + $htpasswd = "$pass_path/.htpass$file_name"; + $exist = 1 if (-e $htpasswd); + } + else { + my $fpasswd = $self->_safe_file(".htpasswd", {fullfile => 1, exist => 1}); + $htpasswd = $fpasswd->{file}; + $exist = 1 if ($fpasswd->{exist}); + } + my $faccess = $self->_safe_file(".htaccess", {fullfile => 1, exist => 1}); + my $htaccess = $faccess->{file}; + + if ($exist and $faccess->{exist}) { + open (HTPAS, "< $htpasswd") or die "Unable to open: $htpasswd ($!)"; + my @users = ; + close HTPAS; + $delete_list = "" if (@users); + } + + return { delete_list => $delete_list, pass_path => $pass_path }; +} +END_OF_SUB + +$COMPILE{list_files} = __LINE__ . <<'END_OF_SUB'; +sub list_files { +# ------------------------------------------------------------------ +# Displays a list of files for a given work_path. +# + my $self = shift; + my $do = shift || 'cmd_main_display'; + my $only_dir = $self->{cfg}->{only_dir}; #only display directory listings + my $work_path = $self->{work_path}; + my $real_work_path = $self->_safe_dir(); + my $html_url = $self->{cfg}->{html_root_url} || ''; + my $url_opts = $self->{url_opts} || ''; + my $url = "$self->{http_ref}?fdo=$do;$url_opts"; + my $list; + +# Check if we have data already to list + if (ref $self->{results} eq 'ARRAY') { + $list = $self->{results}; + } + else { +# Else get the list of files using readdir. + opendir (DIR, $real_work_path) or die sprintf ($LANGUAGE{ERR_READ_DIR}, $real_work_path, "$!"); + @$list = readdir(DIR); + closedir (DIR); + } + +# Create path string + my ($string, $spath, $parent, $path) = ('', '', '', []); + $path = [split /\//, $self->{work_path}] if ($self->{work_path}); + $string = 'root: ' ; + for my $ii (0.. $#$path) { + next if (@$path[$ii] eq ''); + $spath .= (($spath) ? '/' : '').@$path[$ii]; + $parent .= (($parent) ? '/' : '').@$path[$ii] if ($ii < $#$path); + $string .= "/".$path->[$ii].""; + } + +# Create data array to sort + my ($list_dir, $list_file, $readme, $num_objects, $total_space); + foreach my $file (@$list) { + next if ($file eq '.'); + next if ($file eq '..'); + next if (!$self->{in}->cookie('hidden_file') and $file =~ /^\./); #don't show hidden file + + my $fullfile = "$real_work_path/$file"; + next if ($only_dir and (!-d $fullfile)); # next if not directory + + my @stat = stat($fullfile); + my $hash; + $readme = $file if (uc($file) eq 'README'); + @$hash{'name', 'size', 'date', 'perm', 'nsize'} = ($file, $stat[7], $stat[9], $stat[2], $stat[7]); + $hash->{user} = eval { getpwuid($stat[4]); } || ''; + $num_objects++; + + if (-d $fullfile) { + $hash->{disabled} = 1 if not -x _; + $hash->{nsize} = 0; + push @$list_dir, $hash; + } + else { + $hash->{type} = _get_icon($file)->{type}; + $hash->{disabled} = 1 if (!-r $fullfile); + $total_space += $hash->{size}; + push @$list_file,$hash; + } + } + my $orderby = $self->{cgi}->{sb} || $self->{in}->cookie('def_sort') || 'name'; + my $sortdown = !$self->{cgi}->{sd}; + $list_file = $self->qsort($list_file,$orderby,$sortdown) if ($#$list_file > 0); + $list_dir = $self->qsort($list_dir,$orderby,$sortdown) if ($#$list_dir > 0); + +# Get the full filename, file size, file modification date and file permissions. + foreach (@$list_dir) { + $_->{icon} = ""; + $_->{isdir}= '1'; + $_->{type} = 'File Folder'; + $_->{size} = ''; + $_->{date} = _get_date($_->{date}); + $_->{perm} = _print_permissions($_->{perm}); + } + foreach (@$list_file) { + my $spec = _get_icon($_->{name}); + $_->{icon} = ""; + $_->{isdir}= '0'; + $_->{size} = _print_filesize($_->{size}); + $_->{date} = _get_date($_->{date}); + $_->{perm} = _print_permissions($_->{perm}); + } + + my ($sorted, $speed_bar, $output); + @$sorted = ($sortdown) ? (@$list_dir, @$list_file) : (@$list_file, @$list_dir); + +# Prepare output after sort +# Skip pages + my $pg = $self->{cgi}->{pg} || 1; #current page + my $r_pg = $self->{in}->cookie('def_files_page') || 25; + my $def_files = $self->{in}->cookie('def_files_page') || ''; + my $count = 0; + if ($def_files ne 'all' and $pg ne 'all'){ + my $skip = 0; + foreach (@$sorted) { + $skip++; + if (($#$sorted >= $r_pg) and ($pg > 0)) { + my $r_start = ($pg == 1) ? 1 : (($pg - 1) * $r_pg + 1); + next if ($skip < $r_start); + $count++; + last if ($count == $r_pg); + } + push @$output, $_; + } + $speed_bar = $self->speed_bar($#$sorted + 1) if ($#$sorted >= $r_pg); + } +# else all rows + else { + $speed_bar = $self->speed_bar($#$sorted + 1) if ($#$sorted >= $r_pg and $pg eq 'all'); + $output = $sorted; + } + $self->{work_path} and unshift @$output, { + 'icon' => "", + 'name' => "Parent Directory", + 'type' => '', 'size' => ' ', 'date' => ' ', 'perm' => '', 'user' => ' ' + }; + +# Build columns title + my $sort_title; + my $cols; + @$cols{'name', 'size', 'date', 'perm', 'user', 'type', 'view'} = ('Name', 'Size', 'Modified', 'Permissions', 'Owner', 'File Type', 'View'); + foreach (keys %$cols) { + my $temp = "{$_}.'' ; + $temp .= (($_ eq $orderby) ? (($sortdown) ? " " : " ") : ''); + $sort_title->{'s'.$_} = $temp; + } + + my $msg_readme; + if ($readme) { + $msg_readme = "

      Readme File:"; + open (DATA, "<$real_work_path/$readme") or return $self->cmd_main_display({reload => 1, status => "$!"}); + $count = 0; + while () { + chomp; + next if ( $_ =~ /^\#/ or !$_); + $msg_readme .= (($msg_readme)? "
      ":"").$_; + $count++; + last if ($count == 10); + } + close DATA; + $msg_readme .= "

      "; + } + +# Return data + $self->{data} = { + pg => $pg, %$sort_title, + string => $string, + results => $output, + speed_bar => $speed_bar, + readme => $msg_readme, + num_objects => $num_objects, + total_space => $total_space, + count => ($count) ? (($count > 10) ? $count - 1 : $count) : $#$output + 1, + }; + + if ($self->{cfg}->{allowed_space}){ + my $disk_space = $self->_checkspace(); + foreach (keys %$disk_space) { + $self->{data}->{$_} = $disk_space->{$_}; + } + $self->{data}->{allowed_space} = sprintf('%.1fMB', $self->{cfg}->{allowed_space} / (1024*1024)); # Format space limit + } + + return 1; +} +END_OF_SUB + +$COMPILE{cmd_show} = __LINE__ . <<'END_OF_SUB'; +sub cmd_show { +# ------------------------------------------------------------------ +# display with unusual template +# + my ($self, $args) = @_; + $args ||= {}; + my $template = $self->{cgi}->{page} || 'file_editor.html'; + + if ($template eq 'file_editor.html') { + ($self->{cgi}->{content} =~ /\
      {cgi}->{content} =~ s/{cgi}->{content} = $self->{in}->html_escape($self->{cgi}->{content}) if (!$args->{error} and $self->{cgi}->{content}); + + if (!defined $args->{use_html} and $self->get_browser(1) and !$self->{in}->cookie('editor_mode')) { + $args->{use_html} = 1; + } + return $self->page($template, { + editor_mode => (!$self->{in}->cookie('editor_mode')) ? 0 : 1, + rows => $self->{in}->cookie('rows') || 20, + cols => $self->{in}->cookie('cols') || 100, + %$args + }); + } + elsif ($template eq 'preferences.html') { + my $def_passwd_dir = $self->{in}->cookie('def_passwd_dir') || $self->{cgi}->{def_passwd_dir}; + $def_passwd_dir =~ s/$self->{cfg}->{root_dir}\/// if (!$self->{cfg}->{passwd_dir_level}); + + return $self->page($template, { + def_sort => $self->{in}->cookie('def_sort') || $self->{cgi}->{def_sort} , + def_working_dir => $self->{in}->cookie('def_working_dir') || $self->{cgi}->{def_working_dir}, + def_files_page => $self->{in}->cookie('def_files_page') || 25, + def_pages_screen => $self->{in}->cookie('def_pages_screen') || 20, + readme_position => $self->{in}->cookie('readme_position') || 'Y', + hidden_file => $self->{in}->cookie('hidden_file') || '0', + editor_mode => $self->{in}->cookie('editor_mode') || '0', + passwd_dir_level => $self->{cfg}->{passwd_dir_level}, + def_passwd_dir => ($def_passwd_dir eq '0') ? '' : $def_passwd_dir, + %$args + }); + } + $self->page ($template,$args); +} +END_OF_SUB + +$COMPILE{cmd_cd} = __LINE__ . <<'END_OF_SUB'; +sub cmd_cd { +#------------------------------------------------------------------ +# CD command +# + my $self = shift; + my $result = $self->_cd_check(); + return $self->cmd_main_display({ reload => 1, status => $result->{status} }, 1) if ($result->{status}); # not safe + + $self->{work_path} = $result->{work_path}; + $self->{cgi}->{work_path} = $result->{work_path}; + $self->cmd_main_display(); +} + +sub _cd_check { +#---------------------------------------------------------------- +# check cd command +# + my $self = shift; + + my $input = $self->{cgi}->{txt_input}; + my $root_path = $self->{cfg}->{root_dir}; + my $fulldir = $self->_safe_dir($input,{ exist => 1, write => 1}); + + return {status => sprintf($LANGUAGE{ERR_INVALID}, $input), work_path => ''} if ($fulldir == -1); # not safe + return {status => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $input), work_path => ''} if (ref $fulldir eq 'HASH' and !$fulldir->{exist}); # not exist + + (my $dir = $fulldir->{fulldir}) =~ s,$root_path/,,; + return { status => '', work_path => $dir}; +} +END_OF_SUB + +$COMPILE{cmd_search} = __LINE__ . <<'END_OF_SUB'; +sub cmd_search { +#---------------------------------------------------------------- +# Search command +# + my ($self, $repl) = @_; + + my ($results, $string, $spath); + my $sortdown = !$self->{cgi}->{sd}; + my $work_path = $self->{work_path} || ''; + my $orderby = $self->{cgi}->{sb} || $self->{in}->cookie('def_sort') || 'name'; + my $pg = $self->{cgi}->{pg} || '1'; #current page + my $r_pg = $self->{in}->cookie('def_files_page') || '25'; + my $search = $self->{cgi}->{txt_input}; + my $url_opts = $self->{url_opts} || ''; + + $pg = 'all' if ($r_pg eq 'all'); + + my ($r_start, $files); + $search =~ s/[\/\\]//g; + $search =~ s,\*,.*?,g; + $search =~ s,\?,.?,g; + +# Initial value for url + my $scope = $self->{cgi}->{scope}; + my $src_opts= "scope=$scope&c_case=$self->{cgi}->{c_case}&c_content=$self->{cgi}->{c_content}"; + my $url = "$self->{http_ref}?fdo=cmd_main_display&$url_opts"; + my $url_pg = "$self->{http_ref}?cmd_do=cmd_search&cmd=search&txt_input=".(($repl) ? $self->{cgi}->{txt_with} : $search)."&work_path=$work_path&$url_opts"; + my $path = [split /\//, $work_path]; + + if (! $scope) { # All of root + my $fulldir = $self->_safe_dir(); + find($fulldir, sub {push @$files, shift}); + } + else { # Selected files + my $selected = [$self->{in}->param('c_edit')]; + foreach (@$selected) { + my $fulldir = $self->_safe_dir($_); + next if ($fulldir == -1); + find($fulldir->{fulldir}, sub {push @$files, shift}); + $src_opts .= "&c_edit=$_"; + } + } + $url_pg .= "&$src_opts"; + +# Search data + if ($repl) { # replace + $results = $self->_replace($files); + } + else { # search data + if (!$self->{cgi}->{c_content}) { # file name + foreach my $file (@$files) { + my ($name) = $file =~ m,/([^/]+)$,; #just get only the file name + next if ($name eq $self->{work_path}); # don't take the work_path + + if ($self->{cgi}->{c_case}) { # None Case Sensitive + push @$results, $self->_file_info($file) if ($name =~ m,$search,); + } + else { + push @$results, $self->_file_info($file) if ($name =~ m,$search,i); + } + } + } + else { # contents + $results = $self->_search_content($files); + } + } + +#Push data of current page into an output array. + my ($skip, $output, $total_space, $msg); + if ($pg eq 'all') { + $output = $results; + } + else { + $r_start = ($pg == 1) ? 0 : (($pg - 1) * $r_pg ); + for my $ii (0 .. $#$results) { + $total_space += @$results[$ii]->{size}; + if ($ii >= $r_start and $#$output < $r_pg - 1) { + push @$output, @$results[$ii]; + } + } + } + $string = "root: "; + for my $ii (0.. $#$path) { + next if (@$path[$ii] eq ''); + $spath .= (($spath) ? '/' : '') . @$path[$ii]; + $string .= "/".@$path[$ii].""; + } + + if ($#$results >= 0) { + $msg = ($repl) ? sprintf ($LANGUAGE{MSG_REPLA_FOUND}, $#$results + 1, ($scope)? '' : 'in ' . (($work_path) ? '/' : 'Root').$work_path) + : sprintf ($LANGUAGE{MSG_SEACH_FOUND}, $#$results + 1, ($scope)? '' : 'in ' . (($work_path) ? '/' : 'Root').$work_path); + } + else { + $msg = $LANGUAGE{MSG_SEACH_NOTFOUND}; + } + +# Sort data + my ($cols, $sort_title, $speed_bar); + @$cols{'name','size','date','perm','user','type','view'} = ('Name','Size','Modified','Permissions','Owner','File Type','View'); + + foreach (keys %$cols) { + my $temp = "{$_}."" ; + $temp .= ( ( $_ eq $orderby ) ? ( ($sortdown) ? "  ^" : "  v" ) : '' ); + $sort_title->{'s'.$_} = $temp; + } + +# Create speed bar + $speed_bar = $self->speed_bar($#$results,"$url_pg&sb=$orderby") if (($#$results - 1) > $r_pg and $r_pg > 0); + $output = $self->qsort($output,$orderby,$sortdown) if ($#$output > 1); + foreach (@$output) { + $total_space += $_->{size} if ($pg eq 'all'); + $_->{size} = _print_filesize($_->{size}); + $_->{perm} = _print_permissions($_->{perm}); + $_->{date} = _get_date($_->{date}); + } + $self->{data} = { + url => "$self->{http_ref}", + results => $output,%$sort_title, + string => $string, + total_space=> $total_space, + num_objects=> (($#$results >=0)? $#$results+1:0), + status => "$msg", + speed_bar => $speed_bar, + search => 1, + reload => 1 + }; + $self->page('main.html',{reload=>1}); +} + +sub _search_content { +#------------------------------------------------------------------- +# search contents +# + my ($self, $files) = @_; + + my $results; + my $search = $self->{cgi}->{txt_input}; + $search = quotemeta($search) if ($self->{cgi}->{c_regex}); + + foreach my $file (@$files) { + if (-T $file) { # Text file + next if (!open(SOURCE, "< $file")); + my $buffer; + if (-s SOURCE < $READ_SIZE) { + read (SOURCE, $buffer, -s SOURCE); + if ($self->{cgi}->{c_case}) { # None Case Sensitive + push @$results, $self->_file_info($file) if ($buffer =~ m,$search,); + } + else { + push @$results, $self->_file_info($file) if ($buffer =~ m,$search,i); + } + } + else { + while (read SOURCE, $buffer, $READ_SIZE) { + if ($self->{cgi}->{c_case}) { #None Case Sensitive + if ($buffer =~ m,$search,) { + push @$results, $self->_file_info($file); + last; + } + } + else { + if ($buffer =~ m,$search,i) { + push @$results, $self->_file_info($file); + last; + } + } + } + } + close SOURCE; + } + } + return $results; +} +END_OF_SUB + +$COMPILE{cmd_replace} = __LINE__ . <<'END_OF_SUB'; +sub cmd_replace { +#----------------------------------------------------------------- +# Search and replace +# + my $self = shift; + $self->cmd_search(1); +} + +sub _replace { +#----------------------------------------------------------------- +# Search and replace contents +# + my ($self, $files) = @_; + + my ($write, $results); + my $search = $self->{cgi}->{txt_input}; + my $with = $self->{cgi}->{txt_with}; + if ($self->{cgi}->{c_word}) { + $search = " $search "; + $with = " $with "; + } + $search = quotemeta($search) if ($self->{cgi}->{c_regex}); + + foreach my $file(@$files) { + if ((-T $file) and (-w $file)) { + next if (!open(SOURCE, "<$file")); + my ($buffer, $found, $tmp); + while (read SOURCE, $buffer, $READ_SIZE) { + if ($self->{cgi}->{c_case}) { #None Case Sensitive + if ($buffer =~ m,$search,) { + $found = 1; + last; + } + } + else { + if ($buffer =~ m,$search,i) { + $found = 1; + last; + } + } + } + close SOURCE; + if ($found) { + my $tempfile = new GT::TempFile; + if (!$self->{cfg}->{winnt}) { + $file =~ m,^([\/\w.-]+)$,; + $file = $1; #untainted + } + + $tmp = _fcopy($file, "$$tempfile.tmp"); + $tmp = _fcopy("$$tempfile.tmp", $file, $search, $with, $self->{cgi}->{c_case}); + _fcopy("$$tempfile.tmp","$file.bak") if ($self->{cgi}->{c_bak}); # create a .bak file + push @$results, $self->_file_info($file) if ($tmp); + + $self->history("cmd_replace|$file|$search with $with") if ( $self->{cfg}->{multi} ); #save log inf + } + } + } + + return $results; +} +END_OF_SUB + +$COMPILE{cmd_command} = __LINE__ . <<'END_OF_SUB'; +sub cmd_command { +#---------------------------------------------------------------- +# execute a command +# + my $self = shift; + $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; #for taint mode + + + my $server_name = $ENV{'SERVER_NAME'}; + my $html_url = $self->{cfg}->{html_root_url}; + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + my $working_dir = $self->{cgi}->{working_dir} || $self->_safe_dir(); + my $cmd = $self->{cgi}->{txt_input} || ''; + my $css_file = $self->{in}->cookie('scheme') || 'fileman'; + my $full_path = $self->{cfg}->{root_dir}.(($work_path)? "/$work_path" : ''); + + my ($prompt, $run_file); + $self->history("cmd_command|$cmd") if ( $self->{cfg}->{multi} );#save log info + + if ($self->{cgi}->{c_edit}) { + $run_file = $full_path.'/'.$self->{cgi}->{c_edit}; + $cmd = $run_file.' '.$cmd; + } + print $self->{in}->header; + chdir ($working_dir); + +# ping command + my $font = $self->{in}->cookie('font'); + if ($cmd =~ m,^\s*ping\s*, or $self->{cgi}->{long}) { + $prompt = $self->{cfg}->{winnt} ? "$working_dir> " : "[". eval { getpwuid($<) } ."\@$server_name ".($working_dir || '/')."]"; + my $command_time_out = $self->{cfg}->{command_time_out} || 60; + my ($pid, $oldfh); + if(!$self->{cfg}->{winnt}) { + $SIG{ALRM} = sub { die "timeout"}; + alarm($command_time_out); + } + print qq! + {cfg}->{html_root_url}/$css_file.css> + + + + + + + + + + + + + + + +
      +

      $font + $prompt $cmd +

      +        !;
      +        eval {
      +                $pid   = open (TMP, "$cmd |");
      +                $oldfh = select(TMP); $| = 1; select($oldfh);
      +                while(){
      +                    s/(\n|\r\n)$//;
      +                    print GT::CGI->html_escape($_), "\n";
      +                }
      +                close (TMP) or die $@;
      +        };
      +        if ($@) {
      +            if ($@ =~ /timeout/) {
      +                my $ret = kill ('INT', $pid);
      +                $ret ? print "Command timed out." : print "Command timed out. Unable to kill: $!";
      +            }
      +            else {
      +                die $@;
      +            }
      +        }
      +        print "

      "; + } + else { +# Other command + my ($output,$errors) = ('',''); + if ($cmd or $self->{cgi}->{runfile}) { + my $tmp_output = new GT::TempFile; # create a result file + my $tmp_errors = new GT::TempFile; # create a error file + if ($self->{cfg}->{winnt}) { #for WinNT + system ("$cmd 1> $$tmp_output 2> $$tmp_errors"); + } + else { + system ("$cmd 2> $$tmp_errors 1> $$tmp_output"); + } + open (TMP, "< $$tmp_output") or return $self->cmd_main_display({reload => 1, status => $!}); + read (TMP, $output, -s TMP); + close TMP; + + open (TMP, "< $$tmp_errors") or return $self->cmd_main_display({reload => 1, status => $!}); + read (TMP, $errors, -s TMP); + close TMP; + if (($cmd =~ m/^\s*cd\s+(.+)/) and !$errors) { + ($self->{cfg}->{winnt} and $working_dir !~ m,^/,) and $working_dir = '/'.$working_dir; + $working_dir = _command_show($working_dir,$cmd) || {}; + ($self->{cfg}->{winnt}) and $working_dir =~ s,/,,; + } + $output = $self->{in}->html_escape($output) if ($output); + $errors ||= ''; + } + my $action = ($cmd)? '' : "onload='top.js_cmd_command(1)'"; + $prompt = $self->{cfg}->{winnt} ? "$working_dir> " : "[". eval { getpwuid($<) } ."\@$server_name ".($working_dir || '/')."]"; + print qq! + + + $font +

      + $prompt $cmd +

      $output
      +
      $errors
      + +
      + + + + + + + + + + + + +
      + !; + } +} +END_OF_SUB + +$COMPILE{cmd_upload} = __LINE__ . <<'END_OF_SUB'; +sub cmd_upload { +# ----------------------------------------------------- +# upload a files +# + my ($self, $data) = @_; + +# $ENV{'PATH'} = ''; #for taint mode warning + $data ||= $self->{in}->param('txt_input'); + + my $work_path = $self->{work_path}; + my $path = $self->{cfg}->{root_dir}.(($work_path)? "/$work_path" : ''); + + if (!-w $path) { # Current directory does not writeable + my $msg = sprintf($LANGUAGE{ERR_FILE_PEM},($work_path) ? $work_path : 'Root'); + ($self->{in}->param('txt_input')) ? return $self->cmd_main_display({ reload => 1 , status => $msg }) : return (0, $msg); + } + + my $free_space = 0; + if ($self->{cfg}->{allowed_space} > 0) { + my $disk_space = $self->_checkspace($self->{cfg}->{root_dir}); + $free_space = $disk_space->{free_space}; + } + + my $filename = $data; + my $mode = $self->{cgi}->{type}; + $filename =~ s/.*?([^\\\/:]+)$/$1/; + $filename =~ s/[\[\]\s\$\#\%'"]/\_/g; + +# Change the name if needed + if ($self->{cgi}->{name} eq 'uppercase') { + $filename =~ s/(\w+)/\U$1/gi; + } + elsif ($self->{cgi}->{name} eq 'lowercase') { + $filename =~ s/(\w+)/\L$1/gi; + } + +# Get the full file name and save the file. + my ($bytesread, $buffer, $fullfile, $file_size); + my $file = $self->_safe_file ($filename, { fullfile => 1, exist => 1, write => 1}); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $filename)}) if ($file == -1); # not safe + + $fullfile = $file->{file}; + if (!$self->{cfg}->{winnt}) { + $fullfile =~ m,^([\/\w.-]+)$,; + $fullfile = $1; #untainted + } + if (!$self->{in}->param('txt_input')) { #multi upload + return (0, sprintf($LANGUAGE{ERR_FILE_EXISTS}, $filename)) if ($file->{exist} and !$self->{cgi}->{overwrite}); + return (0, sprintf($LANGUAGE{ERR_FILE_PEM}, $filename)) if ($file->{exist} and !$file->{write} and $self->{cgi}->{overwrite}); + } + else { + return $self->cmd_main_display({ reload => 1 , status =>sprintf($LANGUAGE{ERR_FILE_EXISTS}, $filename)}) if ($file->{exist} and !$self->{cgi}->{overwrite}); + return $self->cmd_main_display({ reload => 1 , status =>sprintf($LANGUAGE{ERR_FILE_PEM}, $filename)}) if ($file->{exist} and !$file->{write} and $self->{cgi}->{overwrite}); + } + + $file_size = 0; + open (OUTFILE, ">$fullfile") ; + binmode (OUTFILE); + while ($bytesread=read($data,$buffer,1024)) { + if ($mode eq 'ascii') { + $buffer =~ s,\r\n,\n,g; + } + print OUTFILE $buffer; + $file_size += 1024; + if ($self->{cfg}->{allowed_space} > 0) { + if (($file_size / 1024) > $free_space) { + close OUTFILE; + unlink ($fullfile); + ($self->{in}->param('txt_input')) ? return $self->cmd_main_display({ reload => '1', status => $LANGUAGE{ERR_FREE_SPC}}) : return (0,$LANGUAGE{ERR_FREE_SPC}); + } + } + } + + close OUTFILE; + if ($mode eq 'auto') { + if (-T $fullfile) { + open (FILE, "< $fullfile") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile, "$!"); + read (FILE, my $data, -s FILE); + close FILE; + + $data =~ s,\r\n,\n,g; + open (FILE, "> $fullfile") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile, "$!"); + print FILE $data; + close FILE; + $mode = 'ascii/text'; + } + } + +# Change mode + if ($self->{cfg}->{upload_chmod}) { + my $octal_perm = oct($self->{cfg}->{upload_chmod}); # Permissions have to be in octal + chmod($octal_perm, $fullfile) if $octal_perm; # 0 _probably_ means not octal, because 0 is an odd permission to use + } + + my $status; + if (-s $fullfile == 0) { + unlink ($fullfile); + $status = sprintf($LANGUAGE{ERR_UPLOAD}, $filename, "File is 0 bytes."); + } + else { + $status = sprintf($LANGUAGE{UPLOAD_MODE},$filename,$mode); + } + $self->cmd_main_display({ reload=>1 , status => $status}) if ($self->{in}->param('txt_input')); + + if (-e $fullfile || -s $fullfile != 0) { + if ( $self->{cfg}->{multi} ) { #save log info + my $from = $fullfile; + $from =~ s/$path\///; + $self->history("cmd_upload|$from|$path"); + } + return (1, $status); + } + else { + return (0, $status); + } +} +END_OF_SUB + +$COMPILE{cmd_mul_upload} = __LINE__ . <<'END_OF_SUB'; +sub cmd_mul_upload { +# ----------------------------------------------------- +# upload nulti files +# + my $self = shift; + my $count = 0; + my $msg = ''; + for my $i(1..10) { + my $data = $self->{in}->param('file'.$i); + next if (!$data); + my ($result, $status) = $self->cmd_upload ($data); + $result ? $count++ : ($msg .= $status . '
      '); + } + $self->{cgi}->{cmd_do} = 'cmd_upload'; + $self->cmd_main_display ( { reload => 1 , status => $count ? sprintf($LANGUAGE{MSG_MULTI_UPLOAD},$count) : $msg } ); +} +END_OF_SUB + +$COMPILE{cmd_editor} = __LINE__ . <<'END_OF_SUB'; +sub cmd_editor { +#------------------------------------------------------------- +# Editor a text file +# + my $self = shift; + + my $url_opts = $self->{url_opts} || ''; + my $filename = $self->{cgi}->{filename} || ''; + my $work_path= $self->{work_path} || ''; + my $root_path= $self->{cfg}->{root_dir}; + my $data = $self->{cgi}->{content} || ''; + my $fullfile; + +# Store number of rows and cols for TEXTAREA object into cookie + if ($self->{cgi}->{resize}) { + my $rows = $self->{cgi}->{rows} || 20; + my $cols = $self->{cgi}->{cols} || 100; + $rows = 20 if ($rows > 50); + $cols = 100 if ($cols > 200); + print $self->{in}->header( + -cookie => [ + $self->{in}->cookie( -name => 'cols', -value => $cols), + $self->{in}->cookie( -name => 'rows', -value => $rows) + ] + ); + my $size = 0; + if ($filename) { + my $file = $self->_safe_file($filename,{ size => 1}); + $size = $file->{size}; + } + my $status = sprintf($LANGUAGE{MSG_FILE_EDITING}, 'Editing ', $filename, $size, $filename); + return $self->cmd_show({ + content => $self->{in}->html_escape($data), + rows => $rows, + cols => $cols, + status => $status, + use_html => 0, + old => ($self->{cgi}->{filename})? 1 : 0 + }); + } + +# Switch to HTML or TEXT layout + elsif ($self->{cgi}->{switch_edit}) { + my $switch = ($self->{cgi}->{use_html}) ? 0 : 1; + my $filename = $self->{cgi}->{filename}; + if ($filename) { + my $file = $self->_safe_file($filename,{ write => 1, text => 1, fullfile => 1, size => 1, isfile => 1}); + return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_INVALID}, $filename)}) if ($file == -1); # not safe + return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_NOT_FILE}, $filename)}) if (!$file->{isfile}); # not a file + my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'Editing ', $filename, $file->{size}, $filename); + return $self->cmd_show({ + use_html => $switch, + filename => ($filename =~ m,^/,) ? '' : $filename, + old => ($filename =~ m,^/,) ? 0 : 1, + use_html => $switch, + writeable=> $file->{write} + }); + } + else { + return $self->cmd_show({ use_html => $switch }); + } + } + +# Save the contents + ($self->{cgi}->{save}) ? ($filename = $self->{cgi}->{filename}) + : ($filename = $self->{cgi}->{filenew}); + + my $old = $self->{cgi}->{fileold}; + my $msg = $self->_valid_name_check($filename); + return $self->cmd_show({msg => $msg, old => $old, use_html => $self->{cgi}->{use_html}}) if ($msg); + + $self->{cgi}->{content} = $self->{in}->html_escape($data); + + my $file = $self->_safe_file($filename, { fullfile => 1, exist => 1}); + return $self->cmd_show({msg => sprintf($LANGUAGE{ERR_INVALID}, $filename), old => $old}) if ($file == -1); # not safe + $fullfile = $file->{file}; + + if (($file->{exist}) and (!$old or $filename eq $self->{cgi}->{filenew})) { #file already exists + my $tempfile = new GT::TempFile; + open (FILE, "> $$tempfile.tmp") or return $self->cmd_show({ msg => $LANGUAGE{ERR_TMP_FILE}, old => $old}); + print FILE $data; + close FILE; + return $self->page('file_editor_confirm.html', { filename => $filename, tmp_file => "$$tempfile.tmp"}); + } + $self->editor_process($filename,$data); +} +END_OF_SUB + +$COMPILE{editor_process} = __LINE__ . <<'END_OF_SUB'; +sub editor_process { +#------------------------------------------------------- +# Save the contents to a file +# + my ($self, $filename, $contents) = @_; + + if (!$filename) { + $filename = $self->{cgi}->{filename}; + my $tmp_file ||= $self->{cgi}->{tmp_file}; + open (DATA,"<$tmp_file") or return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{ERR_TMP_FILE}, error => 1 }); + read (DATA, $contents, -s DATA); + close DATA; + } + + my $file = $self->_safe_file($filename,{ fullfile => 1}); + my $old = $self->{cgi}->{fileold}; + + if ($file == -1) { + $self->{cgi}->{content} = $self->{in}->html_escape($contents); + return $self->cmd_show({msg => sprintf($LANGUAGE{ERR_INVALID}, $filename), old => $old, error => 1 }); # not safe + } + my $fullfile = $file->{file}; + + open(FILE,">$fullfile") or return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_FILE_OPEN}, $filename), old => $old, error => 1 }); +# Strip windows linefeeds. + $contents =~ s,\r\n,\n,g; + print FILE $contents; + close(FILE); + + if (-e $fullfile) { + $self->history("cmd_edit|$fullfile") if ( $self->{cfg}->{multi} ); #save log info" + $self->{cgi}->{cmd_do} = 'cmd_command'; + my $status = (!$old) ? sprintf($LANGUAGE{MSG_FILE_CREATED}, $filename) : sprintf($LANGUAGE{MSG_FILE_EDITED}, $filename); + return $self->cmd_main_display({ reload => '1', status => $status}); + } + return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_FILE_SAVE}, $filename)}); +} +END_OF_SUB + +$COMPILE{cmd_makedir} = __LINE__ . <<'END_OF_SUB'; +sub cmd_makedir { +#----------------------------------------------- +# Make directory +# + my $self = shift; + +# Get the full path. + my $new = $self->{cgi}->{txt_input}; + my $msg = $self->_valid_name_check($new); + return $self->cmd_main_display({ reload => '1', status => $msg}) if ($msg); + + my $work_path = $self->{work_path} || ''; + my $fulldir = $self->_safe_dir($new, { exist => 1 } ); + + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}, $new)}) if $fulldir == -1; + if ($fulldir->{exist}) { + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_DIR_EXISTS}, $new)}); + } + else { + my ($name) = $fulldir->{fulldir} =~ /\/([^\/]+)$/; + (my $path = $fulldir->{fulldir}) =~ s,/$name$,,; + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $self->{cgi}->{txt_input}) }) if (!-e $path); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_PEM}, $self->{cgi}->{txt_input}) }) if (!-w $path); #permission + } + + + if (rmkdir ($fulldir->{fulldir}, 0755)) { + $self->history("cmd_makedir|$fulldir->{fulldir}") if ( $self->{cfg}->{multi} ); #save log info + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{MSG_DIR_CREATED}, $new) }); + } + + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_DIR_PEM},($new =~ m,^/,) ? $new : ($work_path || 'Root'))}); +} +END_OF_SUB + +$COMPILE{cmd_preferences} = __LINE__ . <<'END_OF_SUB'; +sub cmd_preferences { +#--------------------------------------------------- +# Save options of system +# + my $self = shift; + ($self->{cgi}->{save}) or return $self->cmd_main_display(); + + my $def_sort = $self->{cgi}->{def_sort} || 'Name'; + my $def_working_dir = $self->{cgi}->{def_working_dir} || '/'; + my $def_passwd_dir = $self->{cgi}->{def_passwd_dir}; + my $def_files_page = $self->{cgi}->{def_files_page} || (($self->{cgi}->{showall})? 'all': 25); + my $def_pages_screen= $self->{cgi}->{def_pages_screen} || (($self->{cgi}->{showall})? 'all': 20); + my $hidden_file = $self->{cgi}->{hidden_file} || '0'; + my $editor_mode = $self->{cgi}->{editor_mode} || '0'; + my $scheme = $self->{cgi}->{scheme} || 'fileman'; + my $font = $self->{cgi}->{font} || ""; + my $readme_position = $self->{cgi}->{readme_position}; + + ($font =~ /^$/) or $font = ""; + $def_files_page = 25 if ($def_files_page > 100); + $def_pages_screen = 20 if ($def_pages_screen > 50); + $def_working_dir =~ s/$GT::FileMan::UNSAFE_PATH//g; + $def_passwd_dir =~ s/$GT::FileMan::UNSAFE_PATH//g; + $def_passwd_dir = "$self->{cfg}->{root_dir}/$def_passwd_dir" if ($def_passwd_dir and !$self->{cfg}->{passwd_dir_level}); + $def_passwd_dir ||= '0'; + + if ($def_passwd_dir and (!-e $def_passwd_dir or !-w _)) { + $self->{cgi}->{page} = 'preferences.html'; + (-e _) or return $self->cmd_show( {msg => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $def_passwd_dir)} ); + (-w _) or return $self->cmd_show( {msg => sprintf($LANGUAGE{ERR_DIR_PEM}, $def_passwd_dir)} ); + } + print $self->{in}->header ( + -cookie => [ + $self->{in}->cookie ( -name => 'def_sort', -value => $def_sort, -expires => '+5y'), + $self->{in}->cookie ( -name => 'def_passwd_dir', -value => $def_passwd_dir, -expires => '+5y'), + $self->{in}->cookie ( -name => 'def_working_dir', -value => $def_working_dir, -expires => '+5y'), + $self->{in}->cookie ( -name => 'def_files_page', -value => $def_files_page, -expires => '+5y'), + $self->{in}->cookie ( -name => 'def_pages_screen',-value => $def_pages_screen, -expires => '+5y'), + $self->{in}->cookie ( -name => 'readme_position', -value => $readme_position, -expires => '+5y'), + $self->{in}->cookie ( -name => 'hidden_file' , -value => $hidden_file, -expires => '+5y'), + $self->{in}->cookie ( -name => 'scheme' , -value => $scheme, -expires => '+5y'), + $self->{in}->cookie ( -name => 'font' , -value => $font, -expires => '+5y'), + $self->{in}->cookie ( -name => 'editor_mode' , -value => $editor_mode, -expires => '+5y'), + ] + ); + $self->{cgi}->{cmd_do} = 'cmd_command'; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_PREFERENCES}, re_scheme => 1 }); +} +END_OF_SUB + +$COMPILE{user_form} = __LINE__ . <<'END_OF_SUB'; +sub user_form { +#--------------------------------------------------- +# Save options of system +# + my ($self, $msg) = @_; + ($self->{cfg}->{multi} or $self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION}; + $self->page('user_form.html', { msg => $msg}); +} +END_OF_SUB + +$COMPILE{cmd_admin} = __LINE__ . <<'END_OF_SUB'; +sub cmd_admin { +#--------------------------------------------------- +# Save user password +# + my $self = shift; + ($self->{cfg}->{multi} or $self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION}; + ($self->{cfg}->{single}) and return $self->pwd_single(); + + my $username = $self->{cgi}->{Username}; + my $old_pass = $self->{cgi}->{Old_Password}; + my $new_pass = $self->{cgi}->{New_Password}; + my $db_name = $self->{cfg}->{db_name}; + + return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD}) if (!$old_pass); + return $self->user_form($LANGUAGE{ERR_NEW_PASSWORD}) if (!$new_pass or length($new_pass) < 3); + + open (DATA, "<$self->{cfg}->{priv_path}/$db_name") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$db_name, "$!")},1); + flock(DATA, 1); + my @lines = ; + close DATA; + my $found; + +# check username and password + LINE: foreach (@lines) { + if ($_ =~ /^$/) { next LINE; } + if ($_ =~ /^#/) { next LINE; } + chomp ($_); + $_ =~ s/\r//g; # Remove Windows linefeed character. + my @record = split (/\Q|\E/o, $_); + if (($record[1] ne $username) or ($record[2] ne crypt($old_pass,$old_pass))) { next LINE;} + $found = 1; + last; + } + ($found) or return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD}); + +# Save user information + my $rows; + LINE: foreach (@lines) { + if ($_ =~ /^$/) { next LINE; } + if ($_ =~ /^#/) { next LINE; } + chomp ($_); + $_ =~ s/\r//g; # Remove Windows linefeed character. + my @record = split (/\Q|\E/o, $_); + if ($username eq $record[1]) { # replace user information + $record[2] = crypt($new_pass,$new_pass); + $rows .= join("|",@record); + } + else { + $rows .= $_; + } + $rows .= "\n"; + } + open (NEW, ">$self->{cfg}->{priv_path}/$db_name") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$db_name, "$!")}, 1); + flock(NEW, 2); + print NEW $rows; + close NEW; + return $self->cmd_main_display({reload => 1, status => $LANGUAGE{MSG_PWD_CHANGED}},1); +} +END_OF_SUB + +sub pwd_single () { +#------------------------------------------------------ +# Change password in single version +# + my $self = shift; + ($self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION}; + my $fn = "$self->{cfg}->{priv_path}/lib/ConfigData.pm"; + (-e $fn) or return $self->user_form(sprintf($LANGUAGE{ERR_OPEN_FILE},'ConfigData.pm',$!)); + (-w _) or return $self->user_form(sprintf($LANGUAGE{ERR_WRITEABLE},'ConfigData.pm',$!)); + + my $old = $self->{cgi}->{Old_Password}; + my $new = $self->{cgi}->{New_Password}; + return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD}) if (!$old); + return $self->user_form($LANGUAGE{ERR_NEW_PASSWORD}) if (!$new and length($new) < 3); + return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD}) if (crypt($old,$self->{cfg}->{password}) ne $self->{cfg}->{password}); + +# Encrypt password + my @salt_chars = ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/'); + my $salt = join '', @salt_chars[rand 64, rand 64]; + $self->{cfg}->{password} = crypt($new, $salt); + my $time = localtime; + open (FH, "> $fn") or return $self->user_form(sprintf($LANGUAGE{ERR_OPEN_FILE},'ConfigData.pm',$!)); + print FH <dump ( var => '', data => $self->{cfg} ); + close FH; + print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'password', -value => crypt($self->{cfg}->{password}, $self->{cfg}->{username}), -expires => '') ]); + return $self->cmd_main_display({reload => 1, status => $LANGUAGE{MSG_PWD_CHANGED}},1); +} + +$COMPILE{log_off} = __LINE__ . <<'END_OF_SUB'; +sub log_off { +#--------------------------------------------------- +# Log off +# + my $self = shift; + print $self->{in}->header( -cookie => [ + $self->{in}->cookie( -name => 'username', -value => '', -expires => ''), + $self->{in}->cookie( -name => 'password', -value => '', -expires => '') + ]); + return $self->page('login_form.html', { msg => $LANGUAGE{MSG_LOG_OFF} }); +} +END_OF_SUB + +$COMPILE{cmd_view} = __LINE__ . <<'END_OF_SUB'; +sub cmd_view { +#--------------------------------------------------- +# View a file +# + my ($self,$filename) = @_; + $filename ||= $self->{cgi}->{c_edit}; + my $file = $self->_safe_file($filename, { write => 1, text => 1, fullfile => 1, size => 1}); + return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$filename)}) if ($file == -1); # not safe + + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + my $fullfile = $file->{file}; + my ($ext) = $fullfile =~ /\.([^.]+)$/; + my $img_type = "bmp gif jpg jpeg tif tiff"; + my $status = sprintf($LANGUAGE{MSG_FILE_EDITING}, 'View ', $filename, -s $fullfile, $filename); + + return $self->page('view_image.html', { filename => $filename, work_path=> $work_path, status => $status }) if (($img_type =~ m,$ext,i) and $ext); + $self->_view_file($filename); +} +END_OF_SUB + +$COMPILE{cmd_edit} = __LINE__ . <<'END_OF_SUB'; +sub cmd_edit { +#------------------------------------------------------------- +# Print the content of a file +# + my ($self, $filename, $use_html) = @_; + + $filename ||= $self->{cgi}->{c_edit}; + my $file = $self->_safe_file($filename,{ write => 1, text => 1, fullfile => 1, size => 1, isfile => 1}); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $filename) }, 1) if ($file == -1); # not safe + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_NOT_FILE}, $filename) }, 1) if (!$file->{isfile}); # not a file + + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + my $fullfile = $file->{file}; + my ($ext) = $fullfile =~ /\.([^.]+)$/; + $use_html ||= ''; + if ($file->{text} and $ext ne 'pdf') { # Text file + open (DATA,"<$fullfile") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$filename, "$!")},1); + read (DATA, my $content, -s DATA); + close DATA; + if ( $self->get_browser(1) and !$use_html and !$self->{in}->cookie('editor_mode') and ((lc($ext) eq 'html') or (lc($ext) eq 'htm')) ) { #should show HTML mode + $use_html = 1; + $content =~ s/
      {in}->html_escape($content); + my $status = sprintf($LANGUAGE{MSG_FILE_EDITING}, 'Editing ', $filename, $file->{size}, $filename); + $self->cmd_show({ + content => $content, + filename => ($filename =~ m,^/,)? '' : $filename, + status => $status, + old => ($filename =~ m,^/,)? 0 : 1, + use_html => $use_html, + writeable=> $file->{write} + }); + return; + } +# Image file + my $img_type = "bmp gif jpg jpeg tif tiff"; + my $status = sprintf($LANGUAGE{MSG_FILE_EDITING}, 'View ', $filename, -s $fullfile, $filename); + return $self->page('view_image.html', { filename => $filename, work_path => $work_path, status => $status }) if ($img_type =~ m,$ext,i); + + my $doc = "doc xls pdf DOC XLS PDF mp3 MP3 mpga MPGA mpg MPG"; + return $self->_view_file($filename) if ($doc =~ m,$ext,i); # .doc, .xls, .pdf file + return $self->cmd_tar($filename) if ($ext =~ /tar|gz|zip/i); + return $self->_send_to_browser($fullfile); # Download if it is an unknow file +} +END_OF_SUB + +$COMPILE{cmd_print_img} = __LINE__ . <<'END_OF_SUB'; +sub cmd_print_img { +#---------------------------------------------------------------- +# print image file +# + my $self = shift; + + my $filename = $self->{cgi}->{filename}; + $self->_view_file($filename); +} +END_OF_SUB + +$COMPILE{cmd_download} = __LINE__ . <<'END_OF_SUB'; +sub cmd_download { +#---------------------------------------------------------------- +# download a file +# + my $self = shift; + + my $files = [ $self->{in}->param('c_edit') ]; + my $mode = $self->{cgi}->{chmode} || 'binary'; + my $zip_type = $self->{cgi}->{opt_gz}; + if ($#$files == 0) { + my $file = $self->_safe_file($self->{in}->param('c_edit'), { fullfile => 1}); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $self->{in}->param('c_edit'))}) if ($file == -1); # not safe + return $self->_send_to_browser($file->{file}, $mode) if (-f $file->{file} and !$zip_type); + } + $zip_type ||= 1; + my $tempfile = new GT::TempFile; + my $ext; + if ($zip_type == 3 and $GT::FileMan::HAVE_AZIP) { + my $error = $self->_zip_process("$$tempfile.zip", $files); + return $self->cmd_main_display({ reload => 1, status => "$error" }) if ($error); + $ext = 'zip'; + } + elsif ( $zip_type == 2 and $GT::FileMan::HAVE_GZIP ) { + $self->_tar_process("$$tempfile.tar.gz", $files); + $ext = 'tar.gz'; + } + else { + $self->_tar_process("$$tempfile.tar", $files); + $ext = 'tar'; + } + $self->_send_to_browser("$$tempfile.$ext", 'auto', "download.$ext"); +} +END_OF_SUB + +sub _send_to_browser { +#---------------------------------------------------------------- +# send the contents of a file to browser for downloading +# + my $self = shift; + my $send_file = shift; + my $mode = shift; + my $name = shift; + + if ($mode eq 'auto') { + (-T $send_file) and $mode = 'ascii'; + } + if(open(SENDFILE, $send_file)) { + $self->history("cmd_download|$send_file") if ($self->{cfg}->{multi}); #save log file + + my $file_size = -s $send_file; + if (! $name) { ($name) = $send_file =~ m,/([^/]+)$,; } + print $self->{in}->header( + '-type' => 'application/download', + '-Content-Length' => $file_size, + '-Content-Transfer-Encoding' => 'binary', + '-Content-Disposition' => \"attachment; filename=\"$name\"" + ); + ($self->{cfg}->{winnt}) and binmode STDOUT; + binmode SENDFILE; + my $buffer; + while (read(SENDFILE, $buffer, $READ_SIZE)){ + if ($mode eq 'ascii') { + $buffer =~ s,\r\n,\n,g; + } + print $buffer; + } + close SENDFILE; + } + else { # failed to open file + $send_file =~ s,$self->{cfg}->{root_path},,; + $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN}, $send_file, "$!") }); + } +} + +$COMPILE{cmd_copy} = __LINE__ . <<'END_OF_SUB'; +sub cmd_copy { +# -------------------------------------------------------- +# Copy files or/and directories +# + my $self = shift; + + my $files; + my ($count_copied, $not_copied, $history) = (0, 0, ''); + +# Prepare files and dirs need to copy + @$files = $self->{in}->param('c_edit'); + my $to_dir = $self->_safe_file($self->{cgi}->{txt_input},{ exist => 1, write => 1, fullfile => 1 }); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $self->{cgi}->{txt_input}) }) if ($to_dir == -1); # not safe + if ($to_dir->{exist}) { + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_PEM}, $self->{cgi}->{txt_input}) }) if (!$to_dir->{write}); #permission + } + else { + my ($file) = $to_dir->{file} =~ /\/([^\/]+)$/; + (my $path = $to_dir->{file}) =~ s,/$file$,,g; + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $self->{cgi}->{txt_input}) }) if (!-e $path); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_PEM}, $self->{cgi}->{txt_input}) }) if (!-w $path); #permission + } + + foreach ( @$files ) { + my $from = $self->_safe_file($_, { fullfile => 1, size => 1 }); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$_) }) if ($from == -1); # not safe + next if ($from->{file} eq $to_dir->{file}); # don't copy to itself or it will loop infinitely. + +# Check free space. + if ($self->{cfg}->{allowed_space} > 0) { + my $need_space; + (-d $from->{file})? find($from->{file}, sub {$need_space += -s shift}) : ($need_space = -s $from->{file}); #current file/dir size + my $disk_space = $self->_checkspace(); + my $free_space = $disk_space->{free_space}; + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DISK_SPACE}, $free_space) }) if ($free_space*1024 < $need_space); + } + + if (copy($from->{file}, $to_dir->{file})) { + $count_copied++; + } + else { + $not_copied++; + } + + } + if ($history) { + chop $history; + $self->history("cmd_copy|$history") if ( $self->{cfg}->{multi} ); #save log info + } + + $self->{cgi}->{cmd_do} = "cmd_copy"; + return $self->cmd_main_display( { reload => 1, status => sprintf($LANGUAGE{MSG_COPIED}, $count_copied, $not_copied) }); +} +END_OF_SUB + +$COMPILE{cmd_move} = __LINE__ . <<'END_OF_SUB'; +sub cmd_move { +# -------------------------------------------------------- +# Move files or/and directories +# + my $self = shift; + + my ($count_moved, $not_moved, $history) = (0, 0, ''); + my $files; + @$files = $self->{in}->param('c_edit'); + +# Prepare files and dirs need to move + my $to_dir = $self->_safe_file($self->{cgi}->{txt_input}, { exist => 1, write => 1, fullfile => 1 }); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $self->{cgi}->{txt_input}) }) if ($to_dir == -1); # not safe + + if ($to_dir->{exist}) { + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_PEM}, $self->{cgi}->{txt_input}) }) if (!$to_dir->{write}); #permission + } + else { + my ($file) = $to_dir->{file} =~ /\/([^\/]+)$/; + (my $path = $to_dir->{file}) =~ s,/$file$,,g; + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $self->{cgi}->{txt_input}) }) if (!-e $path); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_DIR_PEM}, $self->{cgi}->{txt_input}) }) if (!-w $path); #permission + } + + foreach (@$files) { + my $from = $self->_safe_file($_, { fullfile => 1 }); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$_) }) if ($from == -1); # not safe + next if ($from->{file} eq $to_dir->{file}); # don't copy to itself or it will loop infinitely. + if (move($from->{file},$to_dir->{file})) { + $count_moved++; + } + else { + $not_moved++; + } + } + if ($history) { + chop $history; + $self->history("cmd_move|$history") if ( $self->{cfg}->{multi} ); #save log info + } + + $self->{cgi}->{cmd_do} = "cmd_move"; + return $self->cmd_main_display( { reload => 1, status => sprintf($LANGUAGE{MSG_MOVED}, $count_moved, $not_moved) }); +} +END_OF_SUB + +$COMPILE{cmd_delete} = __LINE__ . <<'END_OF_SUB'; +sub cmd_delete { +# -------------------------------------------------------- +# Delete files or directories +# + my $self = shift; + + my ($files, $notdeleted); + my ($count_file, $count_dir, $history) = (0, 0, ''); + +#List files and dirs need to remove + @$files = $self->{in}->param('c_edit'); + foreach (@$files) { + my $file = $self->_safe_file($_, { fullfile => 1 }); + if ($file == -1) { + $self->{cgi}->{cmd_do} = "cmd_command" ; + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$_) }); # not safe + } + my $full_name = $file->{file}; + if ( -d $full_name and !-l $full_name ) { + if ( rmdir($full_name) ) { + $count_dir++; + } + else { + push @$notdeleted,$_; + } + } + else { + if ( del($full_name) ) { + $count_file++; + $history .= "$full_name:"; + } + } + } + if ($history) { + chop $history; + $self->history("cmd_delete|$history") if ( $self->{cfg}->{multi} ); #save log info + } + + $self->list_files(); + my $status = ( $count_file > 0 or $count_dir > 0 ) ? sprintf($LANGUAGE{MSG_DEL_SUCC}, $count_file, $count_dir) : $LANGUAGE{ERR_DEL}; + if ($notdeleted) { +# Return list file for loop if recursive diectory + my $list_files; + foreach ( @$notdeleted ) { + push @$list_files, { name => $_ }; + } + $self->{cgi}->{cmd_do} = "cmd_del_confirm"; + return $self->page('confirm_delete.html', { reload => 1, list_files => $list_files, file_cur => @$files[0], status => $status }); + } + else { + $self->{cgi}->{cmd_do} = "cmd_command"; + $self->cmd_main_display({ reload => 1, status => $status }); + } +} +END_OF_SUB + + +$COMPILE{cmd_del_confirm} = __LINE__ . <<'END_OF_SUB'; +sub cmd_del_confirm { +# -------------------------------------------------------- +# confirm before delete a directory have sub dir +# + my $self = shift; + + my $full_path = $self->_safe_dir(); + my ($files, $history); + + if ( $self->{in}->param('c_edit') ) { + @$files = $self->{in}->param('c_edit'); +#Confirm remove all recursive directorys + if ( $self->{cgi}->{all} ) { + foreach ( @$files ) { + my $file = $self->_safe_file($_,{fullfile => 1}); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$_)}) if ($file == -1); # not safe + my $full_name = $file->{file}; + deldir($full_name); + $history .= "$full_name:"; + } + if ($history and $self->{cfg}->{multi}) { + chop $history; + $self->history("cmd_delete|$history"); #save log info + } + $self->{cgi}->{cmd_do} = "cmd_command"; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_ALL}}); + } + +#Remove current recursive directory + elsif ($self->{cgi}->{over}) { + my $file_cur = pop(@$files); + my $file = $self->_safe_file($file_cur,{ fullfile => 1 }); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $file_cur) }) if ($file == -1); # not safe + + my $full_name = $file->{file}; + deldir($full_name); + $history .= "$full_name:"; + + my $list_files; + foreach (@$files) { + push @$list_files, { name => $_ }; + } + if ($#$files >= 0) { + $self->{cgi}->{cmd_do} = "cmd_del_confirm"; + my $status = sprintf($LANGUAGE{MSG_DEL_CURR}, $self->{cgi}->{file_cur}); + return $self->page('confirm_delete.html',{ reload => 1, list_files => $list_files, file_cur => @$files[0] }, status => $status); + } + } +#Skip remmoving current dir + elsif ($self->{cgi}->{skip}) { + pop(@$files); + my $list_files; + foreach (@$files) { + push @$list_files, { name => $_ }; + } + if ($#$files >= 0) { + $self->{cgi}->{cmd_do} = "cmd_del_confirm"; + my $status = sprintf($LANGUAGE{MSG_DEL_SKIP}, $self->{cgi}->{file_cur}); + return $self->page('confirm_delete.html',{ reload => 1, list_files => $list_files, file_cur => @$files[0]}, status => $status); + } + } + +#Cancel delete recursive + elsif ($self->{cgi}->{cancel}) { + $self->{cgi}->{cmd_do} = "cmd_command"; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_CANC} }); + } + } + if ($history and $self->{cfg}->{multi}) { + chop $history; + $self->history("cmd_delete|$history"); #save log info + } + $self->{cgi}->{cmd_do} = "cmd_command"; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_ALL_SUCC} }); +} +END_OF_SUB + +$COMPILE{cmd_print} = __LINE__ . <<'END_OF_SUB'; +sub cmd_print { +# -------------------------------------------------------- +# Print selected file(s) +# + my $self = shift; + + my @input = $self->{in}->param('c_edit'); + my $all = $self->{cgi}->{print_all}; + +# Check the selected files + my @files; + foreach my $n ( @input ) { + my $f = $self->_safe_file($n, { text => 1, fullfile => 1, size => 1, isfile => 1}); + next if ( $f == -1 ); + next if ( !$f->{isfile} ); + + my ($ext) = $n =~ /\.([^.]+)$/; + my $img = ($ext =~ /^jpg|JPG|gif|GIF|bmp|BMP|mpga|MPGA/) ? 1 : 0; + $all = 0 if ($img); + + if ($f->{text} or $img) { + push @files, { name => $n, fullfile => $f->{file}, image => $img }; + } + } + return $self->_js_alert($LANGUAGE{ERR_PRINT}) if ($#files < 0); + + my $output = qq!
      + + !; + + if ($all) { # Print multiple files + my $flag = ''; + foreach my $f (@files) { + open (FILE, "< $f->{fullfile}") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $f->{fullfile}, "$!"); + read (FILE, my $data, -s FILE); + close FILE; + + my $style; + $flag and $style = "style='page-break-before: always;'"; + $output .= qq| +
      +
      +
      $data
      +
      +
      + |; + $flag++; + } + } + else { # Print single file + my $file = pop @files; + + my $next_url = ''; + if ( $#files >= 0 ) { + $next_url = $self->{in}->url (absolute => 1, query_string => 0)."?fdo=cmd_print&&work_path=$self->{work_path}&"; + $next_url .= ";$self->{url_opts};" if ($self->{url_opts}); + foreach ( @files ) { + $next_url .= "c_edit=$_->{name}&"; + } + } + if ($file->{image}) { + $self->page('image_print.html', { + filename => $file->{name}, + work_path => $self->{work_path}, + next_url => $next_url + }); + } + else { + open (FILE, "< $file->{fullfile}") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $file->{fullfile}, "$!"); + read (FILE, my $data, -s FILE); + close FILE; + $output .= qq|
      $data

      |; + $output = sprintf($LANGUAGE{PRINT_NEXT}, $next_url) .$output if ( $next_url ); + } + } + $output .= qq!!; + + print $self->{in}->header; + print $output; +} +END_OF_SUB + +sub _js_alert { +#--------------------------------------------------------- +# + my ($self, $msg) = @_; + print $self->{in}->header; + print qq! +
      + +
      + + !; +} + +$COMPILE{cmd_chmod} = __LINE__ . <<'END_OF_SUB'; +sub cmd_chmod { +# -------------------------------------------------------- +# Changes the permission attributes of a file + + my $self = shift; + + my $newperm = $self->{cgi}->{txt_input}; + my $count = 0; + my $full_path = $self->_safe_dir(); + my $files = $self->{cgi}->{c_edit}; + my $history = "cmd_chmod|"; + my $octal_perm= oct($newperm); + +#if only one file + (ref $files eq 'ARRAY') or $files = [$files]; + foreach (@$files) { + my $from = $self->_safe_file($_, { fullfile => 1 }); + next if ($from == -1); # not safe + + if ($self->{cgi}->{opt_gz} and -d $from->{file}) { + find($from->{file}, sub { + chmod($octal_perm, shift); + }); + $count++; + } + else { + $history .= "$from->{file}:"; + chmod($octal_perm, $from->{file}) and $count++; + } + } + chop $history; + + $self->history($history) if ($self->{cfg}->{multi});#save log info + + my $status = ( $count ) ? sprintf($LANGUAGE{MSG_CHMOD_CHANGED}, $count) : $LANGUAGE{ERR_CHMOD}; + $self->cmd_main_display({ reload => 1, status => $status }); +} +END_OF_SUB + + +$COMPILE{cmd_tail} = __LINE__ . <<'END_OF_SUB'; +sub cmd_tail { +#----------------------------------------------------- +# tail command +# + my $self = shift; + + my $filename = $self->{cgi}->{c_edit}; + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + my $file = $self->_safe_file($filename,{fullfile => 1, exist => 1, isfile => 1, size => 1}); + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID},$filename)}) if ($file == -1); #not safe + + my $fullfile = $file->{file}; + my $retime = $self->{cgi}->{retime}; + my $contents = ''; + my $lines = $self->{cgi}->{txt_input} || 10; + + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS}, $filename) }) if (!$file->{exist}); + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_ISFILE}, $filename) }) if (!$file->{isfile}); + + my $follow; + @ARGV = grep { if ($_ eq "-f") { $follow++; 0 } else { 1 } } @ARGV; + + open FILE, "<$fullfile" or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_OPEN},$filename)}); + my $file_size = $file->{size}; + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_EMPTY}, $filename)}) unless $file_size; + + print $self->{in}->header; + if ($retime) { + print qq! + +!; + } + + my $css_file = $self->{in}->cookie('scheme') || 'fileman'; + print qq! + {cfg}->{html_root_url}/$css_file.css> + + + + + + + + + + + + + + + + + +
      +!;
      +    my $read_size = 4096;
      +    my $to_read   = ($file_size > $read_size) ? $read_size : $file_size;
      +    my $buffer;
      +    seek FILE, -$to_read, 2;
      +    read FILE, $buffer, $to_read;
      +    my $read       = $to_read;
      +    my $need_lines = $lines - 1;
      +    while () {
      +        if ($buffer =~ /\n(.*(?:\n.*){$need_lines}\n?$)/) {
      +            print $self->{in}->html_escape($1);
      +            last;
      +        }
      +        $to_read = ($file_size - $read > $read_size) ? $read_size : $file_size - $read;
      +        unless ($to_read == 0) {
      +            print $self->{in}->html_escape($buffer);
      +            last;
      +        }
      +        seek FILE, -($to_read + $read), 2;
      +        $read += $to_read;
      +        my $new_buffer;
      +        my $bytes_read = read FILE, $new_buffer, $to_read;
      +        if ($bytes_read == 0) {
      +            print $self->{in}->html_escape($buffer);
      +            last;
      +        }
      +        $buffer = $new_buffer . $buffer;
      +    }
      +
      +    my $cnt = 0;
      +    if ($follow) {
      +        seek FILE, 0, 2; # Seek to the end of the file
      +        while () {
      +            select undef, undef, undef, 1;
      +            seek FILE, 0, 1 or last; # Reset eof(FILE)
      +            print while ;
      +            seek FILE, 0, 2;
      +            last if ($cnt++ > 60); # Only run for one min max.
      +        }
      +    }
      +    print "
      "; +} +END_OF_SUB + + +$COMPILE{cmd_perl} = __LINE__ . <<'END_OF_SUB'; +sub cmd_perl { +#---------------------------------------------------------------- +# check perl syntax +# + my $self = shift; + $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; #for taint mode + + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + print $self->{in}->header; + my $css_file = $self->{in}->cookie('scheme') || 'fileman'; + print qq! + {cfg}->{html_root_url}/$css_file.css> + + +
      + + + + + + + + + + + + !; + my $exts = 'cgi pl pm'; + my $files ; + @$files = $self->{in}->param('c_edit'); + my $redirector = ($self->{cfg}->{winnt} ? " 2>&1 1>&2" : " 1>&1 2>&1"); + foreach (@$files) { + my $file = $self->_safe_file($_, { fullfile => 1, text => 1}); + my $full_name = $file->{file}; + next if (not $file->{text}); + my ($ext) = $full_name =~ /\.([^.]+)$/; + next if ($exts !~ /$ext/i); + my $tmp = $full_name; + $tmp =~ s,$self->{cfg}->{root_dir}/,,; + print "

       $tmp "; + my $check_now = $self->{cfg}->{path_to_perl} . ' -cw -I'.$self->{cfg}->{priv_path}.'/lib '.$full_name.' '.$redirector; + print '

       ',`$check_now`,'
      '; + print ""; + } + print ''; +} +END_OF_SUB + +$COMPILE{cmd_diff} = __LINE__ . <<'END_OF_SUB'; +sub cmd_diff { +#---------------------------------------------------- +# Show difference between two files +# + my $self = shift; + my $filename1 = $self->{cgi}->{c_edit}; + my $filename2 = $self->{cgi}->{txt_input}; + my $file1 = $self->_safe_file($filename1, { fullfile => 1, text => 1, exist => 1 }); + my $file2 = $self->_safe_file($filename2, { fullfile => 1, text => 1, exist => 1 }); + ($file1 == -1) and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}, $filename1) }); + ($file2 == -1) and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}, $filename2) }); + + my $work_path = $self->{work_path} || ''; + my $fullfile1 = $file1->{file}; + my $fullfile2 = $file2->{file}; + + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS}, $filename2) }) if (!$file2->{exist}); + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_TEXT_FILE} , $filename1) }) if (!$file1->{text}); + return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_TEXT_FILE} , $filename2) }) if (!$file2->{text}); + + require GT::FileMan::Diff; + my $diff = GT::FileMan::Diff::html_diff($fullfile1, $fullfile2, 3); + if (!ref $diff) { + $diff == 1 ? return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile1, "$!") }) + : return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile1, "$!") }); + } + + my $back_btn = ($self->{cgi}->{hide_back_button}) ? '' : ""; + print $self->{in}->header; + my $css_file = $self->{in}->cookie('scheme') || 'fileman'; + print qq! + {cfg}->{html_root_url}/$css_file.css> + +
      + $back_btn + + + + + + + + + + + + + $$diff
      +!; + +} +END_OF_SUB + +$COMPILE{cmd_tar} = __LINE__ . <<'END_OF_SUB'; +sub cmd_tar { +#---------------------------------------------------- +# Create tar file +# + my ($self, $fn, $error) = @_; + + if ($fn) { + return $self->_zip_information($fn, $error) if ($fn =~ /.zip$/i and $GT::FileMan::HAVE_AZIP); + return $self->_tar_information($fn, $error) if ($fn =~ /.gz$/i and $GT::FileMan::HAVE_GZIP); + return $self->_tar_information($fn, $error) if ($fn =~ /.tar$/i); # .tar file + } + + my $input = $self->{cgi}->{txt_input}; + my $zip_type = $self->{cgi}->{opt_gz}; + my $from_path = $self->_safe_dir(); + my $fulldir = $self->_safe_dir($input); + ($fulldir == -1) and return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $input) }); # not safe + + my $fullfile = $fulldir->{fulldir}; + my $path = [split /\//,$fullfile]; + my $tar_file = @$path[$#$path]; + my $to_path = $fullfile; + $to_path =~ s/\/@$path[$#$path]//; #path to save tar file + + return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_TAR_NOT_EXISTS}, $input)}) if (!-e $to_path); # check exists the directory + return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_TAR_PEM}, $input)}) if (!-w $to_path); # check permission on this directory + + if ($zip_type == 1) { # create a .tar.gz file + $tar_file .= '.gz' if ($tar_file =~ m/.tar$/i); + $tar_file .= '.tar.gz' if ($tar_file !~ m/.tar.gz$/i); + } + elsif ($zip_type == 2) { # create a .zip file + $tar_file .= '.zip' if ($tar_file !~ /.zip$/i); + } + else { # create a .tar file + $tar_file .= '.tar' if ($tar_file !~ /.tar$/i); + } + +# Check required modules + my $err_check = _tar_check($tar_file); + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{ERR_NO_GZIP} }) if ($err_check); # check permission on this directory + + $fullfile = "$to_path/$tar_file"; + if (!$self->{cgi}->{confirm}) { + if (-e $fullfile) { + my $results; + my $files = [$self->{in}->param('c_edit')]; + foreach my $file (@$files) { + push @$results, { name => $file }; + } + return $self->page('tar_confirm.html', { results => $results, file => $tar_file }); + } + } + if ( $zip_type == 2 ) { + my $error = $self->_zip_process($fullfile, [$self->{in}->param('c_edit')]); + return $self->cmd_main_display({ reload => 1, status => $error }) if ($error); + } + else { + $self->_tar_process($fullfile); + } + $self->{cgi}->{cmd_do} = 'cmd_tar'; + + $self->history($fullfile) if ( $self->{cfg}->{multi} ); #save log info + $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{MSG_TAR_CREATED}, $tar_file) }); +} +END_OF_SUB + +$COMPILE{cmd_uncompress} = __LINE__ . <<'END_OF_SUB'; +sub cmd_uncompress { +#-------------------------------------------------------- +# Uncompress .tar or .gz file +# + my $self = shift; + + my $root_path = $self->{cfg}->{root_dir}; + my $work_path = $self->{work_path}; + my $input = $self->{cgi}->{txt_input}; + my $fullfile = $self->_safe_file($self->{cgi}->{cmp_file}, {fullfile => 1, exist => 1}); + my $selected = [$self->{in}->param('c_edit')]; + my $untar_pg = $self->{cgi}->{uncomp_option}; + + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $self->{cgi}->{cmp_file}) }) if ($fullfile == -1); + return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS}, $self->{cgi}->{cmp_file}) }) unless ($fullfile->{exist}); + +# Check required modules + my $error = _tar_check($fullfile->{file}); + return $self->cmd_main_display({ reload => 1, status => $error }) if ($error); + + my $cmp_file = $fullfile->{file}; + return $self->cmd_tar($self->{cgi}->{cmp_file}, $LANGUAGE{ERR_UNCOMPRESS}) if ($#$selected == -1); + +# Check the directory is exists, permission + my $fulldir = $self->_safe_dir($input, { exist => 1, write => 1 }); + return $self->cmd_tar($self->{cgi}->{cmp_file}, sprintf($LANGUAGE{ERR_INVALID}, $input || $work_path)) if ($fulldir == -1); # not safe + return $self->cmd_tar($self->{cgi}->{cmp_file}, sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS}, $input || $work_path || 'Root')) if (ref $fulldir eq 'HASH' and !$fulldir->{exist}); + return $self->cmd_tar($self->{cgi}->{cmp_file}, sprintf($LANGUAGE{ERR_DIR_PEM} , $input || $work_path || 'Root')) if (ref $fulldir eq 'HASH' and !$fulldir->{write}); + +# Get file size + my $full_path = (ref $fulldir eq 'HASH') ? $fulldir->{fulldir} : $fulldir; + my $total_size = _tar_size($cmp_file); + +# Check free space and writeable + if ($self->{cfg}->{allowed_space} > 0) { + my $disk_space = $self->_checkspace($full_path); + my $free_space = $disk_space->{free_space}; + return $self->cmd_tar($self->{cgi}->{cmp_file}, sprintf($LANGUAGE{ERR_DISK_SPACE}, $free_space)) if ($total_size > $free_space * 1024); + } + + my $filename = $cmp_file; + $filename =~ s/$full_path\///; + $self->page('progress_bar.html', { bar_name => "Un-tarring:", msg => sprintf($LANGUAGE{MSG_READING}, $filename) }); + + my ($last_width, $max_width, $copied) = (-1, 500, 0); + if ($filename =~ /.zip$/i) { + my $zip = Archive::Zip->new($cmp_file) or return $self->cmd_tar($self->{cgi}->{cmp_file}, $!); + foreach ($zip->members) { + my $name = $_->fileName; + my $found = $untar_pg ? 0 : 1; + if ($untar_pg) { + foreach my $f (@$selected) { + if ($f eq $name) { + $found = 1; + last; + } + } + } + $copied += $_->uncompressedSize; + if ($found) { + $zip->extractMember($name, "$full_path/$name"); + } + my $percent = 1 - ($total_size - $copied) / $total_size; + my $img_width= int($max_width * $percent); + my $wpercent = sprintf '%.f%%', 100 * $percent; + if ($img_width != $last_width) { + $self->page('copy_status.html', { + msg => "$name file...".(( $found ) ? 'ok' : 'skip'), + pxs => $img_width, + percent => $wpercent + }); + $last_width = $img_width; + } + } + } + else { # Make sure tar file goes out of scope before loading directory. + require GT::Tar; + my $tar = GT::Tar->open ($cmp_file); + my $files = $tar->files; + foreach (@$files) { + my $name = $_->{name}; + my $found = $untar_pg ? 0 : 1; + if ($untar_pg) { + foreach my $f (@$selected) { + if ($f eq $_->{name}) { + $found = 1; + last; + } + } + } + + $copied += $_->{size}; + if ($found) { + $_->{name} = "$full_path/$name"; + $_->write(); + } + + my $percent = 1 - ($total_size - $copied) / $total_size; + my $img_width= int($max_width * $percent); + my $wpercent = sprintf '%.f%%', 100 * $percent; + if ($img_width != $last_width) { + $self->page('copy_status.html', { + msg => "$name file...".(( $found ) ? 'ok' : 'skip'), + pxs => $img_width, + percent => $wpercent + }); + $last_width = $img_width; + } + } + } + $self->history("cmd_untar|$filename|$full_path") if ($self->{cfg}->{multi}); #save log info + $self->{cgi}->{cmd_do} = 'cmd_tar'; + $filename =~ s,$root_path/,,; + $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{MSG_UNCOMPRESS}, $filename)}); +} +END_OF_SUB + +$COMPILE{cmd_show_passwd} = __LINE__ . <<'END_OF_SUB'; +sub cmd_show_passwd { + my ($self, $msg) = @_; + $self->cmd_main_display({ msg => $msg, show_passwd => 1 }); +} +END_OF_SUB + +$COMPILE{cmd_passwd} = __LINE__ . <<'END_OF_SUB'; +sub cmd_passwd { +# ------------------------------------------------------------------ +# Save username and password +# + my $self = shift; + + my $pass_path = $self->{in}->cookie('def_passwd_dir'); + my $work_path = $self->{work_path} || ''; + my $url_opts = $self->{url_opts} || ''; + + my $htpasswd; + if ($pass_path) { # create .htaccess and .htpasswd in Password directory + my $file_name = $self->_safe_dir(); + $file_name =~ s/[\/ \:]/\_/g; + $htpasswd = "$pass_path/.htpass$file_name"; + if (!-e $htpasswd) { + open (FILE, "> $htpasswd"); + close FILE; + } + } + else { + my $fpasswd = $self->_safe_file(".htpasswd", { fullfile => 1, exist => 1, size => 1}); + $htpasswd = $fpasswd->{file}; + if (!$fpasswd->{exist}) { + open (FILE, "> $htpasswd"); + close FILE; + } + } + my $faccess = $self->_safe_file(".htaccess", { fullfile => 1, exist => 1, size => 1}); + my $htaccess = $faccess->{file}; + if (!$faccess->{exist}) { + open (FILE, "> $htaccess"); + close FILE; + } + + unless (-w $htaccess and -w $htpasswd) { #check writeable + print $self->{in}->header; + print sprintf($LANGUAGE{ERR_FILE_PERM},$htaccess,$htpasswd),'
      ', sprintf($LANGUAGE{MSG_CONTINUE},$self->{http_ref},$work_path,$url_opts); + return; + } + + if ( !$faccess->{exist} or $faccess->{size} == 0 ) { + _create_htaccess($htaccess, $htpasswd); + } + else { + open (HTACC, "< $htaccess") or die "Unable to open: $htpasswd ($!)"; + my @info = ; + close HTACC; + my $found; + LINE: foreach ( @info ) { + if ( $_ =~ /$htpasswd/ ) { + $found = 1; + last;<%delete_list%> + } + } + _create_htaccess($htaccess, $htpasswd) if ( !$found ); + } + + if ($self->{cgi}->{remove_all}) { + if (! unlink($htpasswd)) { + open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)"; + close HTPAS; + } + if (!unlink($htaccess)) {; # delete file + open (HTACC, "> $htaccess") or die "Unable to open: $htaccess ($!)"; + close HTACC; + } + + return $self->cmd_show_passwd($LANGUAGE{MSG_USER_RMALL}); + } + my (@users,$msg); + my $username = $self->{cgi}->{p_username} || ''; + my $password = $self->{cgi}->{p_password} || ''; + my $to_delete = ($self->{cgi}->{remove})? $self->{cgi}->{delete_user} : $username; + + if ($to_delete) { + open (HTPAS, "< $htpasswd") or die "Unable to open: $htpasswd ($!)"; + @users = grep { $_ !~ /^$to_delete:/ } ; + close HTPAS; + $msg = sprintf($LANGUAGE{MSG_USER_DELETED}, $to_delete); + } + + if ($username and $password) { + my @salt_chars = ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/'); + my $salt = join '', @salt_chars[rand 64, rand 64]; + my $encrypted = crypt($password, $salt); + push @users, "$username:$encrypted\n"; + $msg = sprintf($LANGUAGE{MSG_USER_ADDED}, $username); + } + if (($username and $password) or $to_delete) { + open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)"; + print HTPAS join ("", @users); + close HTPAS; + if (!@users) { + if (! unlink($htpasswd)) { + open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)"; + close HTPAS; + } + if (!unlink($htaccess)) {; # delete file + open (HTACC, "> $htaccess") or die "Unable to open: $htaccess ($!)"; + close HTACC; + } + } + } + $self->cmd_show_passwd($msg); +} +END_OF_SUB + +$COMPILE{printenv} = __LINE__ . <<'END_OF_SUB'; +sub printenv { +# ------------------------------------------------------------------ + my $self = shift; + ($self->{cfg}->{multi}) and die "It doesn't support for this version"; + + my $work_path = $self->{work_path} || ''; + print $self->{in}->header ; + print qq! +
      + + + + + + + + + + +

      +!; + print $self->_environment(); +} +END_OF_SUB + +sub history { +#--------------------------------------------------------------------- +# Save the history +# + my ($self,$content) = @_; + return if (!$content); + + my $priv_path = $self->{cfg}->{priv_path}; + my $db_name = 'fileman_history.db'; + + $content = $self->{cfg}->{username} . '|' . $ENV{'REMOTE_ADDR'} . '|' . time . "|$content\n"; + open (DATA,">>$priv_path/$db_name") or die sprintf($LANGUAGE{ERR_OPEN_FILE}, $db_name, $!); + flock(DATA, 2); + print DATA $content; + close DATA; +} + +sub _environment { +# -------------------------------------------------------------------- +# Return HTML formatted environment for error messages. +# + my $self = shift; + my $info = '

      ';
      +
      +# Print GT::SQL error if it exists.
      +    $info .= "System Information\n======================================\n";
      +    $info .= "Perl Version: $]\n";
      +    $info .= "FileMan Version: $self->{cfg}->{version}" if ($self->{cfg}->{version});
      +    $info .= "\n";
      +    my $cmds = $self->{commands};
      +    foreach  (keys %$cmds) {
      +        $info .= $_."\t:";
      +        $info .= ($cmds->{$_})?('enabled'):('disabled');
      +        $info .= "\n";
      +    }
      +    $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";
      +
      +# CGI Parameters and Cookies.
      +    if (ref $self->{in} eq 'GT::CGI') {
      +        if ($self->{in}->param) {
      +            $info .= "CGI INPUT\n======================================\n";
      +            foreach (sort $self->{in}->param) { $info .= "$_ => " . $self->{in}->param($_) . "\n"; }
      +            $info .= "\n\n";
      +        }
      +        if ($self->{in}->cookie) {
      +            $info .= "CGI Cookies\n======================================\n";
      +            foreach (sort $self->{in}->cookie) { $info .= "$_ => " . $self->{in}->cookie($_) . "\n"; }
      +            $info .= "\n\n";
      +        }
      +    }
      +
      +# Environement info.
      +    $info  .= "ENVIRONMENT\n======================================\n";
      +    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
      +    $info .= "
      "; + return $info; +} + +sub _zip_information { +#---------------------------------------------------------------------- +# Show the information about a zip file +# + my ($self, $filename, $status) = @_; + + my $fullfile = $self->_safe_file($filename, { fullfile => 1, exist => 1, size => 1 }); + my $zip = new Archive::Zip($fullfile->{file}) or return $self->cmd_main_display({reload => 0, status => $!}); + + my $cmp_file = $fullfile->{file}; + my $stat = [stat($cmp_file)]; + + my $hits = $zip->members + 1; + my $pg = $self->{cgi}->{pg} || 1; + my $mh = $self->{in}->cookie('def_files_page') || 25; + my $start= ($pg == 1) ? 1 : (($pg - 1) * $mh + 1); + + my @results; + my $total_size = $fullfile->{size}; + my $skip = 0; + if ( $hits > 0 ) { + foreach ( $zip->members ) { + $skip++; + next if ($skip < $start); + my $s = $_->compressedSize; + my $icon = _get_icon($_->fileName); + push @results, { + icon => "{icon} )."' width=14 height=16>", + name => $_->fileName, + size => ( $s ) ? _print_filesize($s) : '', + date => _get_date($_->lastModTime), + chmod => _print_permissions($_->unixFileAttributes), + uid => '', + type => '', + nsize => ( $s ) ? _print_filesize($s) : '' + }; + last if ( $#results + 1 >= $mh ); + } + } + +# Creates the speed bar + my $speed_bar; + if ( $hits > ($self->{in}->cookie('def_files_page') || 25) ) { + $speed_bar = $self->speed_bar($hits, "$self->{http_ref}?cmd_do=cmd_edit&work_path=$self->{work_path}&c_edit=$filename;$self->{url_opts}", 1); + } + if (!$status) { + $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'The content of ', $filename, -s $cmp_file, $filename); + } + $self->page('tar_information.html', { + results => \@results, + count => $#results + 1, + cmp_file => $filename, + user => eval { getpwuid(@$stat[4]); } || '', + total_size => $total_size, + total_space => $total_size, + num_objects => ($#results >= 0 ) ? $#results + 1 : 0, + status => $status, + speed_bar => $speed_bar + }); +} + +sub _tar_information { +#---------------------------------------------------------------------- +# Show information about a tar file +# + my ($self, $filename, $status) = @_; + + my $fullfile = $self->_safe_file($filename, {fullfile => 1, exist => 1, size => 1}); + return $self->cmd_main_display({reload => 0, status => sprintf($LANGUAGE{ERR_INVALID}, $filename)}) if ($fullfile == -1); + return $self->cmd_main_display({reload => 0, status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS}, $filename)}) if (!$fullfile->{exist}); + + my $cmp_file = $fullfile->{file}; + my $stat = [stat($cmp_file)]; + if ($cmp_file =~ m,([^/]*[\.tar\.gz]$),) { + my ($files, @results); + + my $pg = $self->{cgi}->{pg} || 1; + my $mh = $self->{in}->cookie('def_files_page') || 25; + my $start= ($pg == 1) ? 1 : (($pg - 1) * $mh + 1); + + require GT::Tar; + my $tar = GT::Tar->open ($cmp_file) or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$!)}); + $files = $tar->files; + my $total_size = 0; + my $skip = 0; + foreach my $file (@$files) { # get uncompressedsize + $total_size += $file->{size} if ( $file->{size} ); + } + foreach my $file (@$files) { + $skip++; + next if ($skip < $start); + my $spec = _get_icon($file->{name}); + push @results, { + icon => "", + name => $file->{name}, + size => ($file->{type} eq '5')? '': _print_filesize($file->{size}), + date => _get_date($file->{mtime}), + chmod => _print_permissions($file->{mode}), + uid => eval { getpwuid($file->{uid}); } || '', + type => $file->{type}, + nsize => ($file->{type} eq '5')? '': $file->{size} + }; + last if ( $#results + 1 >= $mh ); + } + my $root_path = $self->{cfg}->{root_dir}; + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + my $full_path = $root_path.(($work_path)?'/':'').$work_path; + +# Creates the speed bar + my $speed_bar; + if ( $#$files + 1 > ($self->{in}->cookie('def_files_page') || 25) ) { + $speed_bar = $self->speed_bar($#$files, "$self->{http_ref}?cmd_do=cmd_edit&work_path=$self->{work_path}&c_edit=$filename;$self->{url_opts}", 1); + } + + if (!$status) { + $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'The content of ', $filename,-s $cmp_file, $filename); + } + $self->page('tar_information.html', { + results => \@results, + count => $#$files+1, + cmp_file => $filename, + user => eval { getpwuid(@$stat[4]); } || '', + total_size => $total_size, + total_space => $total_size, + num_objects => ($#results >=0)? $#results + 1:0, + status => $status, + speed_bar => $speed_bar + }); + } +} + +sub _tar_check { + my $file = shift; + if ($file =~ /.zip$/i) { + return $LANGUAGE{ERR_NO_AZIP} unless $GT::FileMan::HAVE_AZIP; + } + elsif ($file =~ /.gz$/i) { + return $LANGUAGE{ERR_NO_GZIP} unless $GT::FileMan::HAVE_GZIP; + } + return; +} + +sub _tar_size { + my $file = shift; + + my $size = 0; + if ($file =~ /.zip$/i) { + my $zip = Archive::Zip->new($file) or return; + foreach ( $zip->members ) { + $size += $_->uncompressedSize; + } + } + else { + require GT::Tar; + my $tar = GT::Tar->open($file); + my $files = $tar->files; + foreach (@$files) { + $size += $_->{size}; + } + } + return $size; +} + +sub _checkspace { +# ----------------------------------------------------- +# Check for allowed disk space to determine whether we can allow +# editing or uploads. +# + my $self = shift; + my $directory = shift || $self->{cfg}->{root_dir}; + + return if (!$self->{cfg}->{allowed_space}); + my ($used_space, $free_space, $allowed_space, $usage) = (0, 0, 0); + find($directory, sub {$used_space += -s shift}); + +# Size in kb + $allowed_space = $self->{cfg}->{allowed_space}/1024; + $used_space /= 1024; + $free_space = $allowed_space - $used_space; + $usage = $used_space / $allowed_space * 100 if ($allowed_space > 0); + return { + free_space => int($free_space), + allowed_space => int($allowed_space), + used_space => int($used_space), + usage => int($usage) + }; +} + +sub _file_info { +#------------------------------------------------------------------ +# Show file information +# + my ($self,$fullfile) = @_; + my $hash; + + my $url_opts = $self->{url_opts} || ''; + my $url = "$self->{http_ref}?fdo=cmd_main_display&$url_opts"; + my $html_url = $self->{cfg}->{html_root_url}; + my $name = $fullfile; + my $work_path = $self->{work_path} || ''; + my $full_path = $self->{cfg}->{root_dir}.'/'.$work_path.(($work_path)?'/':''); + my $stat = [stat($fullfile)]; + $name =~ s/$full_path//; + $hash->{value} = $fullfile; + + if (-d _) { + $hash->{name} = $name; + $hash->{icon} = ""; + $hash->{type} = 'Folder'; + $hash->{isdir}= '1'; + $hash->{size} = 0; + } + else { + my $spec = _get_icon($fullfile); + $hash->{name} = $name; + $hash->{icon} = "{icon}."' width=14 height=16>"; + $hash->{type} = $spec->{type}; + $hash->{isdir} = '0'; + $hash->{size} = @$stat[7]; + $hash->{nsize} = @$stat[7]; + } + $hash->{date} = @$stat[9]; + $hash->{perm} = @$stat[2]; + my $user = eval { getpwuid(@$stat[4]); } || ''; + $hash->{user} = $user; + return $hash; +} + +sub speed_bar { +# ------------------------------------------------------------------ +# Create a speed bar +# + my($self, $rows, $url, $off) = @_; + return if ($self->{cgi}->{pg} eq 'all'); # display all + + my $work_path = $self->{work_path} || ''; + my $sb = $self->{cgi}->{sb} || ''; + my $sd = $self->{cgi}->{sd} || ''; + my $url_opts = $self->{url_opts} || ''; + $url ||= "$self->{http_ref}?fdo=cmd_main_display&work_path=$work_path&sb=$sb&sd=$sd&$url_opts"; + my $cur_pg = $self->{cgi}->{pg} || '1'; + my $pg = ($cur_pg eq 'all')? 1 : $cur_pg; + my $rows_pg = $self->{in}->cookie('def_files_page') || 25; + my $scre_pg = $self->{in}->cookie('def_pages_screen') || 10; + my $pages = int($rows / $rows_pg) + (($rows % $rows_pg > 0) ? 1 : 0); + my $next = ""; + my $next_grey = ""; + my $prev = ""; + my $prev_grey = ""; + my $first = ""; + my $first_grey= ""; + my $last = ""; + my $last_grey = ""; + + my ($speed_bar, $pg_step, $start, $jj); + if ( $scre_pg > 0 ) { + $pg_step = ($pg % $scre_pg > 0) ? int($pg / $scre_pg) + 1 : ($pg / $scre_pg); + } + $start = 1; + + if ($pages > $scre_pg) { + $start = ($pg == $pages) ? ($pg - $scre_pg) + 1 : (($pg_step - 1) * $scre_pg)+1; + $start = ($pages - $start + 1 < $scre_pg) ? $start - ($scre_pg - ($pages - $start + 1)) : $start; + } + + $speed_bar = ($pg > 1) ? "$first $prev " : "$first_grey $prev_grey "; + $speed_bar .= ($pg > $scre_pg)? '...' : ''; + + for my $ii ( $start .. $pages) { + $jj++; + if ($cur_pg eq 'all') { + $speed_bar .= "$ii " + } + else { + $speed_bar .= ($cur_pg == $ii)? "$ii " : "$ii "; + } + if ($jj == $scre_pg) { + $speed_bar .= ( ($pg_step * $scre_pg) < $pages) ? "..." : ""; + last; + } + } + $speed_bar .= ($pg < $pages) ? "$next $last" : "$next_grey $last_grey"; + $speed_bar .= ($cur_pg eq 'all') ? " All " : " All " if ( !$off ); + return $speed_bar; +} + +sub qsort { +# ------------------------------------------------------------------ + my ($self,$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; +} + +sub _zip_process { +#-------------------------------------------------------------- +# Create a .zip file +# + my ($self, $to, $files) = @_; + my $from = $self->_safe_dir(); + + if ($self->{cgi}->{cancel}) { #canceled create tar file + $self->{cgi}->{cmd_do} = 'cmd_tar'; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_TAR_CANCEL}}); + } + my $history = 'cmd_tar|'; + + require Archive::Zip::Tree; + my $zip = Archive::Zip->new(); + my $member; + foreach my $file (@$files) { + if ( -f "$from/$file" ) { + $member = $zip->addFile("$from/$file", $file) or warn "$!"; + } + elsif ( -d "$from/$file" ) { + $member = $zip->addTree("$from/$file", $file) or warn "$!"; + } + } + return $zip->writeToFileNamed($to) ? "$!" : 0; +} + +sub _tar_process { +#-------------------------------------------------------------- +# Create tar file +# + my ($self, $to) = @_; + my $from = $self->_safe_dir(); + + if ($self->{cgi}->{cancel}) { #canceled create tar file + $self->{cgi}->{cmd_do} = 'cmd_tar'; + return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_TAR_CANCEL}}); + } + + my $input = $self->{cgi}->{txt_input}; + my $files = [$self->{in}->param('c_edit')]; + my $history = 'cmd_tar|'; +# Make sure tar file goes out of scope and cleans up temp files + { + my $tar; + require GT::Tar; + $tar = new GT::Tar($to) or return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_TAR},$GT::Tar::error)}); + foreach my $file (@$files) { + my $fulldir = $self->_safe_dir($file); + next if ($fulldir == 1); + $tar->add_file($fulldir->{fulldir}); + } + + my $items = $tar->files; + foreach my $fl (@$items) { + $fl->{name} =~ s/$from\///; + } + $tar->write("$to"); + $history .= "|$to"; + } +} + +sub _safe_file { +#------------------------------------------------------------------------ +# Check a file make sure it safe +# + my ($self, $file, $options) = @_; + + my $root = $self->{cfg}->{root_dir}; + return { file => $root } if ($file eq '/'); + + return -1 if ($self->{cfg}->{filename_check} and $file !~ m,^([-\w/. ]+)$,); + return -1 if ($file =~ /$GT::FileMan::UNSAFE_PATH/); + +# Check if proper work_path (/ stands for root dir, otherwise use current dir) + my $path_to_file = ($file =~ m,^/,) ? $file : "$self->{work_path}/$file"; + $path_to_file =~ s,^/,,; + + my $fullfile = $root.'/'.$path_to_file; + my ($e, $w, $t, $s, $f); + foreach my $key (keys % $options) { + if ($options->{$key} == 1) { + ($key eq 'exist') and $e = -e $fullfile; + ($key eq 'write') and $w = -w $fullfile; + ($key eq 'text') and $t = -T $fullfile; + ($key eq 'size') and $s = -s $fullfile; + ($key eq 'isfile') and $f = -f $fullfile; + } + } + return { + file => ($options->{fullfile} == 1) ? $fullfile : $file, + exist => $e, + write => $w, + text => $t, + size => $s, + isfile => $f, + }; +} + +sub _view_file { +#------------------------------------------------------ +# print the content of a file +# + my ($self,$filename) = @_; + my $file = $self->_safe_file($filename,{ fullfile => 1, size => 1}); + ($file == -1) and return; # not safe + +# Load content-type of a image file. + my $fullfile = $file->{file}; + my $file_size = $file->{size}; + my $content_type = _load_mime($fullfile); + my ($ext) = $fullfile =~ /\.([^.]+)$/; + + if(open(DATA, $fullfile)) { + $self->{in}->reset_env(); + if ((($content_type =~ m/text/) or -T $fullfile) and (uc($ext) ne 'PDF')) { + my $url_opts = $self->{url_opts} || ''; + my $work_path = $self->{work_path} || ''; + print $self->{in}->header; + print qq! +
      + + + + + + + + + + + + + + + + +
      +
        + !; + print '
        ' if (not $content_type =~ m/htm/);
        +        }
        +        else {
        +            print $self->{in}->header({
        +                '-force'          => 1,
        +                '-type'           => $content_type,
        +                '-Content-Disposition' => \"filename=$filename",
        +                '-Content-Length' => $file_size,
        +            });
        +        }
        +        ($self->{cfg}->{winnt}) and binmode STDOUT;
        +        binmode DATA;
        +        my $buffer;
        +        print $buffer while (read(DATA, $buffer , $READ_SIZE));
        +        close(DATA);
        +    }
        +}
        +
        +sub _safe_dir {
        +#------------------------------------------------------------------------
        +# Check a directory make sure it safe
        +#
        +    my ($self, $dir, $options) = @_;
        +
        +    my $root = $self->{cfg}->{root_dir};
        +    my $work = $self->{work_path};
        +
        +    my $fulldir;
        +    unless ($dir) {
        +        return ($work) ? "$root/$work" : $root;
        +    }
        +    elsif ($dir eq '/') {
        +        return $root;
        +    }
        +
        +    return -1 if ($self->{cfg}->{filename_check} and $dir !~ m,^([-\w/. ]+)$,);
        +    return -1 if ($dir =~ /$GT::FileMan::UNSAFE_PATH/);
        +
        +    ($dir =~ m,^/,) ? ($fulldir = $root . $dir)
        +                    : ($fulldir = $root. ($work ? '/' : '') . $work . '/' . $dir);
        +    my ($e, $d, $w);
        +    foreach my $key (keys % $options) {
        +        if ($options->{$key} == 1) {
        +            $e = -e $fulldir if ($key eq 'exist');
        +            $d = -d $fulldir if ($key eq 'isdir');
        +            $w = -w $fulldir if ($key eq 'write');
        +        }
        +    }
        +    return { fulldir => $fulldir, exist => $e, isdir => $d, write => $w };
        +}
        +
        +sub _command_show {
        +#--------------------------------------------------------------------
        +# Show path when execute cd command
        +#
        +    my ($working_dir, $cmd) = @_;
        +    if ($cmd =~ m/^\s*cd\s*\.\./) { # cd ..
        +        my $tmp;
        +        my $parts = [split(/\//, $working_dir)];
        +        return '/' if ($#$parts == 1 or $working_dir eq '/');
        +
        +        foreach my $ii( 0 .. $#$parts) {
        +            $tmp .= '/'.@$parts[$ii] if ($ii < $#$parts and @$parts[$ii]);
        +        }
        +        return $tmp;
        +    }
        +    return $working_dir if ($cmd =~ m/^\s*cd\s*\./); # cd.
        +    my $path = $cmd;
        +    $path    =~ s/\s*cd\s*//;
        +    return '/' if ($path =~ m,^(/+)$,);
        +    return ($path =~ m/^\//)? $path : $working_dir.(($working_dir and $working_dir ne '/')? '/' : '').$path;
        +}
        +
        +sub _get_icon {
        +# ------------------------------------------------------------------
        +# Get the associated icon based on a files extension
        +#
        +    my ($file) = shift;
        +    my ($ext)  = $file =~ /\.([^.]+)$/;
        +    return {icon => 'unknown.gif', type => 'unknown File'} if (!$ext);
        +    foreach (keys %{$ICONS}) {
        +        next if (/folder/);
        +        next if (/unknown/);
        +        next if (/parent/);
        +        ($_ =~ /\b\Q$ext\E\b/i) and return { icon => $ICONS->{$_}[0],type => $ICONS->{$_}[1]};
        +    }
        +    return {icon => 'unknown.gif', type => "$ext File"};
        +}
        +
        +sub _get_date {
        +# ------------------------------------------------------------------
        +    my $time = shift;
        +    $time or ($time = time);
        +    my @months = qw!Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec!;
        +
        +    my ($min, $hr, $day, $mon, $yr) = (localtime($time))[1,2,3,4,5];
        +    $yr = $yr + 1900;
        +    ($min < 10) and ($min = "0$min");
        +    ($hr  < 10) and ($hr  = "0$hr");
        +    ($day < 10) and ($day = "0$day");
        +
        +    return "$day-$months[$mon]-$yr $hr:$min";
        +}
        +
        +sub _print_filesize {
        +# ------------------------------------------------------------------
        +# Prints out the file size.
        +#
        +    my $size = shift;
        +    my $formatted_size = 0;
        +    $formatted_size = int($size / 1000) if ($size);
        +    return $formatted_size == 0 ? "$size bytes" : $formatted_size." kb";
        +}
        +
        +sub _print_permissions {
        +# ------------------------------------------------------------------
        +# Takes permissions in octal and prints out in ls -al format.
        +#
        +    my $octal  = shift;
        +    my $string = sprintf "%lo", ($octal & 07777);
        +    my $result = '';
        +    foreach (split(//, $string)) {
        +        if    ($_ == 7) { $result .= "rwx "; }
        +        elsif ($_ == 6) { $result .= "rw- "; }
        +        elsif ($_ == 5) { $result .= "r-x "; }
        +        elsif ($_ == 4) { $result .= "r-- "; }
        +        elsif ($_ == 3) { $result .= "-wx "; }
        +        elsif ($_ == 2) { $result .= "-w- "; }
        +        elsif ($_ == 1) { $result .= "--x "; }
        +        elsif ($_ == 0) { $result .= "--- "; }
        +        else            { $result .= "unkown '$_'!"; }
        +    }
        +    return $result;
        +}
        +
        +sub _load_mime {
        +# --------------------------------------------------------------------
        +# Load the config file into a hash.
        +#
        +    my $file = shift;
        +    require GT::MIMETypes;
        +    my $guess = GT::MIMETypes->guess_type($file);
        +    if (! $guess) {
        +        if (-e $file) {
        +            $guess = -T _ ? 'text/plain' : 'application/octet-stream';
        +        }
        +        else {
        +            $guess = 'application/octet-stream';
        +        }
        +    }
        +    return $guess;
        +}
        +
        +sub _init_chmod {
        +#---------------------------------------------------------------------
        +# set chmod
        +#
        +    my($from,$to) = @_;
        +    $from =~ m,^([/\w.-]+)$,;
        +    $from = $1;
        +
        +    $to =~ m,^([/\w.-]+)$,;
        +    $to = $1;
        +
        +    my $stat = [stat($from)];
        +    chmod(@$stat[2],$to);
        +}
        +
        +sub _create_htaccess {
        +# ------------------------------------------------------------------
        +# Creates the htaccess file.
        +#
        +    my ($htaccess, $htpasswd) = @_;
        +    my $raq = $ENV{GT_COBALT_RAQ} ? "AuthPAM_Enabled off\n" : '';
        +    open (HTAC, "> $htaccess") or die "Unable to open: $htaccess ($!)";
        +    print HTAC <$to") or return 0;
        +    open(SOURCE, "<$from") or return 0;
        +    binmode SOURCE;
        +    binmode TARGET;
        +    my $buffer;
        +    while (read SOURCE, $buffer, $READ_SIZE) {
        +        if ($repl) {
        +            ($cs)? ($buffer =~ s,$repl,$with,g)
        +                 : ($buffer =~ s,$repl,$with,ig);
        +        }
        +        print TARGET $buffer;
        +    }
        +    close SOURCE;
        +    close TARGET;
        +    _init_chmod($from,$to);
        +    return 1;
        +}
        +
        +sub _valid_name_check {
        +# ---------------------------------------------------
        +# Checks to see if the input database/table name is a
        +# valid one.  The function checks the following:
        +# 1. if a name is entered at all;
        +# 2. if there are spaces in the name;
        +# 3. if the name is consisted of valid characters; and
        +# 4. if the name is consisted of only numbers.
        +
        +    my ($self, $name) = @_;
        +    my ($output);
        +
        +    $name =~ s/^\s+//;
        +    $name =~ s/\s+$//;
        +    if (!$name) {
        +        $output = "Please provide a valid name.";
        +    }
        +    elsif ($self->{cfg}->{filename_check} and $name =~ /\s/) {
        +        $output = "Spaces are not allowed in name.";
        +    }
        +    return $output;
        +}
        +
        +1;
        diff --git a/site/glist/lib/GT/FileMan/Diff.pm b/site/glist/lib/GT/FileMan/Diff.pm
        new file mode 100644
        index 0000000..c606584
        --- /dev/null
        +++ b/site/glist/lib/GT/FileMan/Diff.pm
        @@ -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 
        ...
        . 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||; + $colors{"${_}_close"} = qq||; + } + else { + $colors{$_} = qq||; + $colors{"${_}_close"} = qq||; + } + } + + 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) = '
        ';
        +    $$ret .= '
        '; + + $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; diff --git a/site/glist/lib/GT/MD5.pm b/site/glist/lib/GT/MD5.pm new file mode 100644 index 0000000..945677e --- /dev/null +++ b/site/glist/lib/GT/MD5.pm @@ -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() { + 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 an interface (like C) 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 instead of this module if it is available. +This module is only usefull for + +=over 4 + +=item + +computers where you cannot install C (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. 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 module is available it is used and if not you take +C. + +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 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 for those amounts of data anyway. + +=back + +=head1 SEE ALSO + +L + +L + +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 +(). + +C was made by Gisle Aas (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 . + +=cut diff --git a/site/glist/lib/GT/MD5/Crypt.pm b/site/glist/lib/GT/MD5/Crypt.pm new file mode 100644 index 0000000..b3b76cf --- /dev/null +++ b/site/glist/lib/GT/MD5/Crypt.pm @@ -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): +# 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 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): + 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 provides a function compatible with Apache's +C<.htpasswd> files. This was contributed by Bryan Hart . +As suggested by William A. Rowe, Jr. , it is +exported by default. + +=cut diff --git a/site/glist/lib/GT/MIMETypes.pm b/site/glist/lib/GT/MIMETypes.pm new file mode 100644 index 0000000..0c398a0 --- /dev/null +++ b/site/glist/lib/GT/MIMETypes.pm @@ -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 and C. +They take either a filename or a hash reference. + +C 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 + diff --git a/site/glist/lib/GT/Mail.pm b/site/glist/lib/GT/Mail.pm new file mode 100644 index 0000000..9c1ef7e --- /dev/null +++ b/site/glist/lib/GT/Mail.pm @@ -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" , this will return +# ('Jason Rhinelander', 'jason@gossamer-threads.com'). It handes escapes as +# well - "Jason \(\"jagerman\"\) Rhinelander" +# 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 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 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. 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 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. + +=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 diff --git a/site/glist/lib/GT/Mail/BulkMail.pm b/site/glist/lib/GT/Mail/BulkMail.pm new file mode 100644 index 0000000..37666a3 --- /dev/null +++ b/site/glist/lib/GT/Mail/BulkMail.pm @@ -0,0 +1,1282 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Mail::BulkMail +# Author: Jason Rhinelander +# CVS Info : +# $Id: BulkMail.pm,v 1.46 2005/04/06 01:07:59 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A simple bulk e-mail module to interface with either +# sendmail or SMTP. +# +# ================================================================== + +package GT::Mail::BulkMail; + +use Exporter; +use GT::Socket::Client; +use constants CRLF => "\015\012", CR => "\015", LF => "\012"; +use strict; +use GT::AutoLoader; +use vars qw(@ISA $VERSION $AUTOLOAD @EXPORT_OK %EXPORT_TAGS $VALID_HOST $CRLF $CR $LF $noIPCOpen2); + +eval "use IPC::Open2"; +$noIPCOpen2++ if $@; + +@ISA = qw(Exporter); + +@EXPORT_OK = qw(RFC822_date quoted_printable quote_name unquote_name + $VALID_HOST CR LF CRLF $CR $LF $CRLF); + +%EXPORT_TAGS = ( + quoting => [ qw/quoted_printable quote_name unquote_name/ ], + crlf => [ qw/CR LF CRLF $CR $LF $CRLF/ ], +); + +$VERSION = sprintf "%d.%03d", q$Revision: 1.46 $ =~ /(\d+)\.(\d+)/; + +$VALID_HOST = '(?:[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)*)'; + +$CR = CR; +$LF = LF; +$CRLF = CRLF; + +sub DESTROY { + my $self = shift; + $self->_smtp_disconnect();# if $self->{smtp_connected}; + $self->_sendmail_disconnect();# if $self->{sendmail_connected}; +} + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { }; + bless $self, $class; + $self->_init(@_); + return $self; +} + +# Parses all passed options to new, such as -from, -name, -smtp, etc. +sub _init { + my $self = shift; + my %options = @_; +# These two should be first so that errors can be handled that the others might cause + $self->show_errors(delete $options{-show_errors}) if exists $options{-show_errors}; + $self->error_code(delete $options{-error_code}) if exists $options{-error_code}; + $self->from(delete $options{-from}) if exists $options{-from}; + $self->name(delete $options{-name}) if exists $options{-name}; + $self->subject(delete $options{-subject}) if exists $options{-subject}; + $self->message(delete $options{-message}) if exists $options{-message}; + $self->success(delete $options{-success}) if exists $options{-success}; + $self->failure(delete $options{-failure}) if exists $options{-failure}; + $self->messagepresend(delete $options{-messagepresend}) if exists $options{-messagepresend}; + $self->subjectpresend(delete $options{-subjectpresend}) if exists $options{-subjectpresend}; + $self->frompresend(delete $options{-frompresend}) if exists $options{-frompresend}; + $self->namepresend(delete $options{-namepresend}) if exists $options{-namepresend}; + $self->smtp_retries(0); + $self->smtp_retries(delete $options{-smtp_retries}) if exists $options{-smtp_retries}; + $self->smtp_wait(2.5); + $self->smtp_wait(delete $options{-smtp_wait}) if exists $options{-smtp_wait}; + $self->_method(\%options); # Figures out (sendmail or smtp) and (text or html) + if (keys %options) { + my $forgot_dash = 0; + for (keys %options) { + $self->_cause_error("Unknown parameter `$_'"); + $forgot_dash++ if substr($_, 0, 1) ne '-'; + } + die "Invalid parameters (" . join(", ", keys %options) . ") to new()" . ($forgot_dash ? " - perhaps you forgot the -dash?" : ""); + } +} + +# Tries to figure out whether to use sendmail, or SMTP to send the message by +# looking for the -smtp or -sendmail options. +# Also looks for -text or -html options +sub _method { + my ($self,$options) = splice @_,0,2; + + if ($options->{-sendmail} and $options->{-smtp}) { + $self->_cause_error("Invalid method: Two mailing methods provided. Choose only smtp or sendmail"); + delete $options->{-sendmail}; + delete $options->{-smtp}; + } + elsif ($options->{-sendmail}) { + $self->sendmail(delete $options->{-sendmail}); + delete $options->{-smtp}; + } + elsif ($options->{-smtp}) { + $self->smtp(delete $options->{-smtp}); + delete $options->{-sendmail}; + } + my $t = $options->{-text}; + my $h = $options->{-html}; + my $r = $options->{-raw}; + + if (($h and $r) or ($t and $r) or ($t and $h)) { + $self->_cause_error("Invalid mail format: Choose only one format to use."); + delete $options->{-text}; + delete $options->{-html}; + delete $options->{-raw}; + } + elsif ($options->{-text}) { + $self->text(1); + delete $options->{-text}; + delete $options->{-html}; + delete $options->{-raw}; + } + elsif ($options->{-html}) { + $self->html(1); + delete $options->{-html}; + delete $options->{-text}; + delete $options->{-raw}; + } + elsif ($options->{-raw}) { + $self->raw(1); + delete $options->{-html}; + delete $options->{-text}; + delete $options->{-raw}; + } +} + + +# This subroutine handles the creation of errors and prints them (if +# show_errors is set), and/or passes them to error_code (if set). +$COMPILE{_cause_error} = __LINE__ . <<'END_OF_SUB'; +sub _cause_error { + my $self = shift; + my $error = shift; + warn ref($self)." Error: $error" if $self->{show_errors}; + $self->{error_code}->($error) if ref $self->{error_code} eq 'CODE'; +} +END_OF_SUB + +# All of the following methods (down to _check_params) will return the current +# value of that parameter if called without arguments. + +# Sets a code ref which will be called with an error message each time an +# error occurs. +$COMPILE{error_code} = __LINE__ . <<'END_OF_SUB'; +sub error_code { + my $self = shift; + if (@_) { + if (ref $_[0] eq 'CODE') { + $self->{error_code} = shift; + } + else { + $self->_cause_error("Not a code reference passed to error_code"); + } + } + else { + return $self->{error_code}; + } +} +END_OF_SUB + + +# Sets whether or not to print errors whenever an error occurs. +$COMPILE{show_errors} = __LINE__ . <<'END_OF_SUB'; +sub show_errors { + my $self = shift; + if (@_) { + $self->{show_errors} = shift; + return; + } + return $self->{show_errors}; +} +END_OF_SUB + +# Sets the e-mail address of the sender. Takes one arg: The e-mail address of +# the sender. +sub from ($;$) { + my $self = shift; + if (@_) { + if (_is_valid_email($_[0])) { + $self->{from} = shift; + return 1; + } + else { + $self->_cause_error("Invalid e-mail address: `$_[0]'"); + return; + } + } + else { + return $self->{from}; + } +} + +# Sets the presend code ref for the from field. +# Takes one argument: a code ref +$COMPILE{frompresend} = __LINE__ . <<'END_OF_SUB'; +sub frompresend { + my $self = shift; + if (@_) { + $self->{frompresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{frompresend}; + } +} +END_OF_SUB + +# Sets the body of the message. +# Takes one argument: a string. +sub message ($;$) { + my $self = shift; + if (@_) { + $self->{message} = shift; + return; + } + return $self->{message}; +} + +# Sets a presend code ref for the body of the message. +# Takes a code ref as argument +$COMPILE{messagepresend} = __LINE__ . <<'END_OF_SUB'; +sub messagepresend { + my $self = shift; + if (@_) { + $self->{messagepresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{messagepresend}; + } +} +END_OF_SUB + +# Sets the display name of the sender. Will be escaped and quoted. +# Without args, returns the name (not quoted, of course). +sub name ($;$) { + my $self = shift; + if (@_) { + if (_is_valid_name($_[0])) { + $self->{name} = quote_name(shift); + return 1; + } + else { + $self->_cause_error("Invalid name"); + return; + } + } + else { + return unquote_name($self->{name}); + } +} + +# name presend - takes a code ref +$COMPILE{namepresend} = __LINE__ . <<'END_OF_SUB'; +sub namepresend { + my $self = shift; + if (@_) { + $self->{namepresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{namepresend}; + } +} +END_OF_SUB + +# Sets the subject of the message +sub subject ($;$) { + my $self = shift; + if (@_) { + $self->{subject} = shift; + return; + } + else { + return $self->{subject}; + } +} + +# Sets the subject presend for the e-mail +$COMPILE{subjectpresend} = __LINE__ . <<'END_OF_SUB'; +sub subjectpresend { + my $self = shift; + if (@_) { + $self->{subjectpresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{success} eq 'CODE' + ? $self->{success} + :($self->{success} = undef); + } +} +END_OF_SUB + +# Sets the number of times to attempt connection to the SMTP server before +# giving up. +sub smtp_retries ($;$) { + my $self = shift; + if (@_) { + my $retries = shift; + if (!$retries or $retries =~ /\D/) { + $self->{smtp_retries} = 0; + } + else { + $self->{smtp_retries} = $retries; + } + return; + } + return $self->{smtp_retries}; +} + +# Sets the wait time between SMTP connection reattempts. +sub smtp_wait ($;$) { + my $self = shift; + if (@_) { + my $wait = shift; + unless ($wait and $wait =~ /^\d+(?:\.\d+)?$/) { + $self->{smtp_wait} = 0; + } + else { + $self->{smtp_wait} = $wait; + } + return; + } + return $self->{smtp_wait}; +} + +# Sets that the format of the message should be plain text. +# Note that this does NOT set the text of the message! +$COMPILE{text} = __LINE__ . <<'END_OF_SUB'; +sub text { + my $self = shift; + if (@_) { + $self->{format} = "text/plain" if $_[0]; + return; + } + $self->{format} eq "text/plain"; +} +END_OF_SUB + +# Sets that the format of the message should be HTML +$COMPILE{html} = __LINE__ . <<'END_OF_SUB'; +sub html { + my $self = shift; + if (@_) { + if ($_[0]) { + $self->{format} = "text/html"; + } + else { + $self->{format} = "text/plain"; + } + return; + } + $self->{format} eq "text/html"; +} +END_OF_SUB + +$COMPILE{raw} = __LINE__ . <<'END_OF_SUB'; +sub raw { + my $self = shift; + if (@_) { + $self->{raw} = shift; + return; + } + $self->{raw}; +} +END_OF_SUB + +# Sets a code reference to be called when a message has (as far as the mailer +# can tell) been sent successfully. +$COMPILE{success} = __LINE__ . <<'END_OF_SUB'; +sub success { + my $self = shift; + if (@_) { + $self->{success} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{success} eq 'CODE' + ? $self->{success} + :($self->{success} = undef); + } +} +END_OF_SUB + +# Sets a code reference to call when sending a message as failed. +$COMPILE{failure} = __LINE__ . <<'END_OF_SUB'; +sub failure { + my $self = shift; + if (@_) { + $self->{failure} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{failure} eq 'CODE' + ? $self->{failure} + : ($self->{failure} = undef); + } +} +END_OF_SUB + +# Returns a list of custom headers that have been set +$COMPILE{headers} = __LINE__ . <<'END_OF_SUB'; +sub headers { + my $self = shift; + wantarray ? %{$self->{header}} : $self->{header}; +} +END_OF_SUB + +# Adds a single custom header. The header must start with X- +$COMPILE{add_header} = __LINE__ . <<'END_OF_SUB'; +sub add_header { + my $self = shift; + $self->_cause_error("Wrong number of arguments to add_header()") and return unless @_ == 2; + my ($k,$v) = splice @_,0,2; + $k =~ y/\x00-\x1f://d; + $v =~ s/\r?\n/$CRLF/g; + $v =~ s/(?:$CRLF){2,}/$CRLF/g; + $v =~ s/$CRLF$//; + if (($self->raw) || (substr($k,0,2) eq 'X-')) { + $self->{header}{$k} = $v; + } + else { + $self->_cause_error("Only X-* headers can be added"); + } +} +END_OF_SUB + +# Adds multiple headers. This makes calls to add_header() +$COMPILE{add_headers} = __LINE__ . <<'END_OF_SUB'; +sub add_headers { + my $self = shift; + $self->_cause_error("Wrong number of arguments to add_headers()") and return if @_ % 2; + while (@_) { + $self->add_header(splice @_,0,2); + } +} +END_OF_SUB + +# Deletes (and returns the value of) the header given. +$COMPILE{delete_header} = __LINE__ . <<'END_OF_SUB'; +sub delete_header { + my $self = shift; + my $key = shift; + delete $self->{header}{$key}; +} +END_OF_SUB + +# Deletes (and returns the values of) the headers given. +$COMPILE{delete_headers} = __LINE__ . <<'END_OF_SUB'; +sub delete_headers { + my $self = shift; + delete @{$self->{header}}{@_}; +} +END_OF_SUB + +# Sets the sending method to SMTP and sets the smtp server to the argument +# given. +$COMPILE{smtp} = __LINE__ . <<'END_OF_SUB'; +sub smtp { + my $self = shift; + if (@_) { + my $smtp = shift; + chomp $smtp; + if ($smtp =~ /^$VALID_HOST\Z/) { + $self->{method} = "smtp"; + delete $self->{sendmail}; + $self->{smtp} = $smtp; + $self->{smtp_attempts} = 0; + $self->{smtp_connected} = 0; + delete $self->{handle_in}; + delete $self->{handle_out}; + delete $self->{smtp_supported}; + return 1; + } + else { + $self->_cause_error("Bad SMTP server name provided ($smtp)"); + return; + } + } + else { + return $self->{smtp}; + } +} +END_OF_SUB + +# Sets the sending method to sendmail and sets the sendmail path to the +# argument given. +$COMPILE{sendmail} = __LINE__ . <<'END_OF_SUB'; +sub sendmail { + my $self = shift; + if (@_) { + my $sendmail = shift; + my ($executable, $tags) = split ' ', $sendmail, 2; + if (-x $executable) { + $self->{method} = "sendmail"; + if ($tags) { + $self->{sendmail_with_tags} = $self->{sendmail} = $sendmail; + # Using tags assumes that a method equivelant to -t is being used + $self->{no_sendmail_bs} = 1; + } + else { + $self->{sendmail} = $sendmail; + delete $self->{no_sendmail_bs}; + } + return 1; + } + else { + $self->_cause_error("Cannot execute $sendmail"); + return 0; + } + } + else { + return $self->{sendmail_with_tags} || $self->{sendmail}; + } +} +END_OF_SUB + +# checks that there is enough information set to send the e-mail +sub _check_params { + my $self = shift; + my $errors = ""; + unless ($self->{from}) { + $errors .= "`from' address not set. "; + } + elsif (not _is_valid_email($self->{from})) { + $errors .= "`$self->{from}' is not a valid e-mail address. "; + } + if ($self->{name} and not _is_valid_name($self->{name})) { + $errors .= "`$self->{name}' is not a valid name. "; + } + unless ($self->{$self->{method}}) { + $errors .= "No mail sending method set! "; + } + $errors and $self->_cause_error($errors . "Send aborted."), return; + return 1; +} + +# Checks whether or not the provided e-mail address is valid. +$COMPILE{_is_valid_email} = __LINE__ . <<'END_OF_SUB'; +sub _is_valid_email { + shift if ref $_[0]; + my $email = shift; + return $email && $email =~ /^[\x21-\x7e]+\@$VALID_HOST$/; +} +END_OF_SUB + +# Checks that a name is valid. +$COMPILE{_is_valid_name} = __LINE__ . <<'END_OF_SUB'; +sub _is_valid_name { + shift if ref $_[0]; + my $name = shift; + return not $name =~ y/\x20-\x7e//c; # 7-bit only with no control characters +} +END_OF_SUB + +# Sends an e-mail. Takes multiple arguments: Any number of: +# - array references +# - code references +# - hash references +# - glob references +# See the perldoc of this file for more info +sub send { + my $self = shift; + unless ($self->_check_params) { + $self->_cause_error("Not all neccessary parameters provided. No emails sent."); + return; + } + else { + $self->{date} = RFC822_date(); # Just get it once rather than figuring it out each time. + if ($self->{method} eq 'smtp') { + $self->_smtp_connect(); + } + elsif ($self->{method} eq 'sendmail') { + $self->_sendmail_connect(); + } + for (@_) { + ref eq 'GLOB' and $self->_send_globref($_), next; + ref eq 'HASH' and $self->_send_hashref($_), next; + ref eq 'ARRAY' and $self->_send_arrayref($_), next; + ref eq 'CODE' and $self->_send_coderef($_), next; + $self->_cause_error("Invalid argument to ".ref($self)."->send()"); + } + } +} + +$COMPILE{_send_arrayref} = __LINE__ . <<'END_OF_SUB'; +sub _send_arrayref { + my $self = shift; + my $array = shift; + for (@$array) { + $self->_send_one($_); + } +} +END_OF_SUB + +$COMPILE{_send_coderef} = __LINE__ . <<'END_OF_SUB'; +sub _send_coderef { + my $self = shift; + my $code = shift; + my ($id,$email); + $id = "temp"; + while ($id) { + ($id, $email) = $code->() or last; + $self->_send_one($email ? ($id,$email) : $id); + } +} +END_OF_SUB + +$COMPILE{_send_globref} = __LINE__ . <<'END_OF_SUB'; +sub _send_globref { + my $self = shift; + my $file = shift; + unless (fileno $file) { + $self->_cause_error("Glob reference passed to send is not an opened file"); + return; + } + my $addr; + while ($addr = <$file>) { + $addr =~ s/\r?\n$//; # Allow for windows line ends on *nix systems + $self->_send_one($addr); + } +} +END_OF_SUB + +$COMPILE{_send_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _send_hashref { + my $self = shift; + my $hash = shift; + my ($id,$email); + $self->_send_one($id,$email) while ($id,$email) = each %$hash; +} +END_OF_SUB + +# Sends a single e-mail message. Should not be called except by one of the 4 +# subroutines above. +sub _send_one { + my $self = shift; + my ($id,$email) = @_ > 1 ? (splice @_,0,2) : ((shift) x 2); + substr($email,rindex($email,'@')) =~ y/A-Z/a-z/; + my $success; + my $from = ref $self->{frompresend} eq 'CODE' + ? ($self->{frompresend}->($id,$self->{from}) || $self->{from}) + : $self->{from}; + $from =~ y/\x21-\x7e//cd; + my $name = ref $self->{namepresend} eq 'CODE' + ? quote_name($self->{namepresend}->($id,unquote_name($self->{name}))) || $self->{name} + : $self->{name}; + $name =~ y/\x20-\x7e//cd; + my $subject; + $subject = ref $self->{subjectpresend} eq 'CODE' + ? ($self->{subjectpresend}->($id,$self->{subject}) || $self->{subject}) + : $self->{subject}; + $subject =~ y/\x20-\x7e//cd; + my $message = ref $self->{messagepresend} eq 'CODE' + ? ($self->{messagepresend}->($id,$self->{message}) || $self->{message}) + : $self->{message}; + if ($self->{method}) { + if ($noIPCOpen2 || $self->{no_sendmail_bs} and $self->{method} eq 'sendmail') { + $success = $self->_sendmail_t_send($email,$from,$name,$subject,$message); + } + else { + $success = $self->_smtp_send($email,$from,$name,$subject,$message); + } + } + else { + $self->_cause_error("No mail sending method set!"); + return; + } + if ($success and ref $self->{success} eq 'CODE') { + $self->{success}->($id); + } + elsif (!$success and ref $self->{failure} eq 'CODE') { + $self->{failure}->($id); + } +} + +# Creates a connection to the STMP server +$COMPILE{_smtp_connect} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_connect { + my $self = shift; + $self->_smtp_disconnect if $self->{smtp_connected}; + $self->{method} eq 'sendmail' and return $self->_sendmail_connect; + local $/ = CRLF; + local $\ = CRLF; + + my $s; + $self->{smtp_connected} = 0; + + while (not $self->{smtp_connected} and $self->{smtp_attempts}++ <= $self->{smtp_retries}) { + select(undef,undef,undef,$self->{smtp_wait}) if $self->{smtp_attempts} > 1 + and $self->{smtp_wait} and $self->{smtp_wait} > 0; + + $s = GT::Socket::Client->open( + host => $self->{smtp}, + port => 25, + timeout => 10 + ) or $self->_cause_error("$self->{smtp}: Unable to connect: " . GT::Socket::Client->error); + + $self->{handle_out} = $self->{handle_in} = $s; + $_ = <$s>; + unless (/^220/) { + $self->_cause_error("$self->{smtp}: Server not available: $_"); + close $s; + next; + } + while (/^220-/) { + $_ = <$s>; + } + if (my $error = $self->_smtp_say_hi) { + $self->_cause_error("$self->{smtp}: $error"); + close $s; + next; + } + $self->{smtp_connected} = 1; + } + return $self->{smtp_connected}; +} +END_OF_SUB + +# Disconnects from the SMTP server +sub _smtp_disconnect { + my $self = shift; + return $self->_sendmail_disconnect if $self->{method} eq 'sendmail'; + local $/ = CRLF; + local $\ = CRLF; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + if (defined $out) { + print $out "QUIT"; + } + close $out; + close $in; + delete $self->{handle_out}; + delete $self->{handle_in}; + 1; +} + +# Does all the initialization required before sending a message +$COMPILE{_smtp_say_hi} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_say_hi { + my $self = shift; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + local $/ = CRLF; + local $\ = CRLF; + print $out "EHLO localhost"; + local $_ = <$in>; + return "No server response" unless defined; + if (/^5\d\d\s+(.*)/) { # Not ESMTP + delete $self->{smtp_esmtp}; + print $out "HELO localhost"; + $_ = <$in>; + return "No server response to HELO command (EHLO failed)" unless defined; + } + else { + $self->{smtp_esmtp}++; + } + s/$CRLF/\n/; + return "Invalid server response: $_" if !/^\d{3}/; + return "Server error: $_" if /^[45]/; + return if /^250 /; # Just a plain SMTP greeting + while (defined($_=<$in>) and /^250-/) { # 250- is a possible greeting, indicating more lines coming. + s/$CRLF/\n/; + /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1"; + } + !defined || /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1"; + return; +} +END_OF_SUB + +# Actually sends the message using SMTP protocols. +$COMPILE{_smtp_send} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_send { + my ($self,$to,$from,$name,$subject,$message) = @_; + return unless _is_valid_email($to); + local $/ = CRLF; + local $\ = CRLF; + local $_; + + unless ($self->{smtp_connected}) { + $self->_smtp_connect(); + } + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + print $out "RSET"; + $_ = <$in>; + s/$CRLF$//; + if (not defined or /^(?:221|[45]\d\d)\s*(.*)/) { + $self->_cause_error("Cannot reset connection: ".($1 || "No response from server").". Reconnecting"); + $self->{smtp_attempts} = 0; # It could be that the server will only take one connection, although + # this defeats any advantage this module has over any module designed to send just one message. + unless ($self->_smtp_connect()) { + $self->_cause_error("Fatal: Could not reestablish connection"); + die "Could not reestablish connection"; + } + } + if (/^221\s*(.*)/) { + $self->_smtp_disconnect(); + $self->_cause_error("Server disconnected: $1"); + return; + } + + my $return = $self->{header}->{'Return-Path'}; + if ($return) { + print $out "MAIL FROM: <$return>"; + } + else { + print $out "MAIL FROM: <$from>"; + } + + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect(); + $self->_cause_error("Server disconnected: $1"); + return; + } + unless (/^250/) { + # The error message won't be helpful here (it will be a syntax error). + # The only way an error can occur here is for an invalid email address. + $self->_cause_error("From address (`$from') rejected by server ($_)"); + # If the from was rejected once, it will be rejected again. + die "From address (`$from') rejected by server."; + } + print $out "RCPT TO: <$to>"; + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect; + $self->_cause_error("Server disconnected: $1. Attempting to reconnect..."); + $self->{smtp_attempts} = 0; + unless ($self->_smtp_connect()) { + $self->_cause_error("Fatal error: Could not reestablish connection"); + die "Could not reestablish connection"; + } + return &_smtp_send; # redo this mail + } + unless (/^25[01]/) { + /^\d{3}\s*(.*)/; + $self->_cause_error("Recipient ($to) refused by server: $1"); + return; + } + print $out "DATA"; + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect; + $self->_cause_error("Server disconnected: $1. Attempting to reconnect..."); + $self->{smtp_attempts} = 0; + unless ($self->_smtp_connect) { + $self->_cause_error("Fatal error: Could not reestablish connection"); + die "Could not reestablish connection"; + } + return &_smtp_send; # redo this mail + } + unless (/^354/) { + $self->_cause_error("Invalid server response to DATA ($_). Attempting to reset and resend."); + return &_smtp_send; + } + my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $]; + $from = "$name <$from>" if defined $name and $name =~ /\S/; + print $out "Return-Path: $return" if ($return); + print $out "Date: $self->{date}"; + print $out "From: $from"; + print $out "Subject: $subject"; + print $out "To: $to"; + print $out "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'}; + print $out "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'}; + print $out "Content-Type: $self->{format}" if $self->{format}; + 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 ($host) { + print $out 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>'; + } + while (my ($k,$v) = each(%{$self->{header}})) { + next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id'; + print $out "$k: $v"; + } + print $out ""; + $message =~ s/\015?\012/$CRLF/g if $self->{raw}; + $message = quoted_printable($message) unless $self->{raw}; + $message =~ s/^\./../gm; + print $out $message; + print $out "."; + $_ = <$in>; + return /^250/; +} +END_OF_SUB + +# Establishes a sendmail -bs (emulates SMTP) connection via IPC::Open2 +$COMPILE{_sendmail_connect} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_connect { + my $self = shift; + local $/ = CRLF; + local $\ = CRLF; + my $in = \do { local *INPUT; *INPUT; }; + my $out = \do { local *OUTPUT; *OUTPUT; }; + $self->_smtp_disconnect if $self->{sendmail_pid} or $self->{smtp_connected}; + my $pid = eval { open2($in,$out,"$self->{sendmail} -bs") }; + + $self->{handle_in} = $in; + $self->{handle_out} = $out; + if ($@) { + # Could not run sendmail at all + $self->_cause_error("Unable to open sendmail: $@"); + return; + } + $_ = <$in>; + s/\n$//; + unless (/^220/) { + # sendmail can be run, but apparently it doesn't like the -bs option + $self->_cause_error("$self->{sendmail}: SMTP compatible mode not available: $_. Using -t mode instead."); + close $in; + close $out; + waitpid $pid,0; + $self->{no_sendmail_bs}++; + return 1; + } + while (/^220-/) { + $_ = <$in>; + } + if (my $error = $self->_smtp_say_hi) { + $self->_cause_error("Sendmail (SMTP mode) error: $error"); + close $in; + close $out; + waitpid $pid,0; + return; + } + $self->{sendmail_pid} = $pid; + $self->{smtp_connected} = 1; + return 1; +} +END_OF_SUB + +# Disconnects from sendmail (in sendmail -bs mode) +$COMPILE{_sendmail_disconnect} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_disconnect { + my $self = shift; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + my $pid = $self->{sendmail_pid}; + close $in if $in; + close $out if $out; + waitpid $pid, 0 if $pid; + delete $self->{handle_in}; + delete $self->{handle_out}; + delete $self->{sendmail_pid}; + delete $self->{smtp_connected}; + 1; +} +END_OF_SUB + +# Sends with sendmail -t mode. This should only be called when IPC::Open2 is +# not available or sendmail does not support the -bs switch. It is intended as +# a backup solution only. +$COMPILE{_sendmail_t_send} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_t_send { + my ($self,$to,$from,$name,$subject,$message) = splice @_,0,6; + local $/ = LF; + local $\ = LF; + return unless _is_valid_email($to); + local *SENDMAIL; + my $to_open = $self->{sendmail_with_tags} || "$self->{sendmail} -t -oi -odq"; + unless (open(SENDMAIL, "| $to_open")) + { + $self->_cause_error("Can't run sendmail ($to_open): $!"); + return; + } + $from = "$name <$from>" if defined $name and $name =~ /\S/; + my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $]; + my $return = $self->{header}->{'Return-Path'}; + print SENDMAIL "Return-Path: $return" if ($return); + print SENDMAIL "Date: $self->{date}"; + print SENDMAIL "From: $from"; + print SENDMAIL "Subject: $subject"; + print SENDMAIL "To: $to"; + print SENDMAIL "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'}; + print SENDMAIL "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'}; + print SENDMAIL "Content-Type: $self->{format}" if $self->{format}; + my $host = $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : ''; + if ($host) { + print SENDMAIL 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>'; + } + while (my ($k,$v) = each %{$self->{header}}) { + next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id'; + print SENDMAIL "$k: $v"; + } + $message = quoted_printable($message) unless $self->{raw}; + $message =~ s/^\.$LF$/. $LF/gm; + print SENDMAIL $message; + close SENDMAIL; + !$?; +} +END_OF_SUB + +# Returns the argument passed with quotes around it and special characters +# escaped for use in the From: line of an e-mail. +sub quote_name { + shift if ref $_[0]; # In case you call $self->quote_name($string); + my $toquote = shift; + $toquote =~ s/(?=[(")\\])/\\/g; + substr($toquote,0,0) = '"'; + $toquote .= '"'; + $toquote; +} + +# unquotes (as per the above) the argument +$COMPILE{unquote_name} = __LINE__ . <<'END_OF_SUB'; +sub unquote_name { + shift if ref $_[0]; + my $tounquote = shift; + $tounquote =~ s/^"// and $tounquote =~ s/"$//; + $tounquote =~ s/\\(?=.)//g; + return $tounquote; +} +END_OF_SUB + +# Takes a string and returns it in quoted-printable encoding. +sub quoted_printable { + shift if ref $_[0]; + my $string = shift || ""; + $string =~ s/$CRLF|$CR|$LF|\r\n/\n/g; + $string =~ s/([^\x09\x20-\x3c\x3e-\x7e\n])/sprintf "=%02X",ord $1/eg; + $string =~ s/(^.{73})(?==[0-9A-F]{2}.)/$1=\n/gm; + $string =~ s/(^.{74})(?==[0-9A-F]{2})/$1=\n/gm; + $string =~ s/((?:^|\G).{75})(?=..)/$1=\n/gm; + $string =~ s/(^.{74})(.?)\x20$/$1$2=\n=20/gm; + $string =~ s/(^.{74})(.?)\x09$/$1$2=\n=09/gm; + $string =~ s/\x20$/=20/gm; + $string =~ s/\x09$/=09/gm; + $string =~ s/\r?\n/$CRLF/g; + $string; +} + +# Returns an RFC822 compliant date. +sub RFC822_date (;$$) { + require GT::Date; + GT::Date->import(':timelocal'); + shift if ref $_[0]; + my $time = @_ ? shift : time; + my @lt = localtime($time); + my @ut = gmtime($time); + use integer; + my $tzs = (timegm(@lt) - timelocal(@lt)); + my $tzh = $tzs / 3600; + my $tzm = $tzs % 60 / 60; + my $tz = 100*$tzh + 60*$tzm; + no integer; + sprintf( + "%s, %02d %s %04d %02d:%02d:%02d %+05d", + (qw/Sun Mon Tue Wed Thu Fri Sat/)[$lt[6]], + $lt[3], + (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/)[$lt[4]], + $lt[5] + 1900, + @lt[2,1,0], + $tz + ); +} + +1; + +__END__ + +=head1 NAME + +GT::Mail::BulkMail - A (perhaps overly) simplified interface to sending bulk emails + +=head1 SYNOPSIS + + $mailer = new GT::Mail::BulkMail; + $mailer->option("setting"); + $mailer->otheroption("othersetting"); + ... + + -- or -- + + $mailer = new GT::Mail::BulkMail( + -option => "setting", + -otheroption => "othersetting", + ... + ); + + + + -- then -- + + + sub subroutine { + # Code to generate the next e-mail address + } + open FILE, "email_list.txt"; + %hash = ( 1 => 'some@fictional.address', + 2 => 'who@knows.where' + ); + @array = ('yet@another.fictional.address','and@one.more'); + $mailer->send(\&subroutine,\*FILE,\%hash,\@array); + close FILE; + + +=head1 DESCRIPTION + +GT::Mail::BulkMail is a module to handle mass mailings. It is capable of +using either sendmail, or an SMTP server. It has the advantage of +not requiring multiple connections to the SMTP server. + +=head1 REQUIREMENTS + +Perl 5.004 + +=head2 METHODS + +All methods can be specified at object creation time as an option with the: +S<-option =E value> syntax. For example, C<$mailer = new GT::Mail::BulkMail(-from =E "foo@bar.com")> +would have the same effect as: C<$mailer = new GT::Mail::BulkMail(); $mailer-Efrom("foo@bar.com")> + +=over 4 + +=item smtp + +Sets the SMTP server to use, and sets the object mail sending method to use SMTP. Takes +SMTP server as argument. + +=item sendmail + +Sets the sendmail executable to use. Takes the path to sendmail as the argument. + +=item text + +Specifies that the mail format is text. This translates into Content-type: text/plain. +This is the default format. + +=item html + +Specifies that the mail format is HTML. (Content-type: text/html) + +=item headers + +Returns any custom headers set as a hash reference in scalar context, or a hash in list context. + +=item add_header + +Adds a single header. This can be any header starting with "X-" (Note that X-Mailer headers +will be prepended with the GT::Mail::BulkMail X-Mailer header (which includes the perl version, +OS name, GT::Mail::BulkMail module and CVS versions, and the Gossamer Threads homepage)). Pass +two arguments: A key (header name) and a value (header value). For example, for +C you would use: $mailer->add_header("X-Foo" => "blah blah blah") + +=item add_headers + +Same as above, except it adds multiple headers. Has the same argument format. You would use: +$mailer->add_headers("X-Foo1" => "blah", "X-Foo2" => "blah blah"); + +=item delete_header + +Deletes a single header. Pass the name of the header to delete. + +=item delete_headers + +Delete multiple headers. Pass a list of names of headers to delete. + +=item from + +Sets the "from" field of the e-mail. Must be set before $mailer-Esend() can be called. +Must be set to an e-mail address. If this e-mail address is rejected by the SMTP server, +no e-mails will be sent. + +=item name + +Sets the "name" field of the e-mail. This affects what is displayed in the "From" field. +When sending the email, the actual field will be set to: C<"This name" Esome@name.netE>. +Optional. + +=item subject + +Sets the subject of the message. If not specified, it will default to "(no subject)" + +=item message + +The body of the message. Can be left blank, but that seems rather pointless... +The message will be encoded using the quoted-printable format if it contains characters +outside the 7-bit range. + +=item success + +A code reference to be run for each and every successful e-mail sending. +Each call to this code reference will be given the e-mail address as the only argument +(unless using a message ID, which is discussed below). Optional. + +=item failure + +A code reference that will be run for any email addresses that cannot be sent. Each +call to this code reference will be given the ID or e-mail address as the argument +(message IDs are discussed below). Optional. + +=item frompresend + +=item namepresend + +=item subjectpresend + +=item messagepresend + +A code reference that will be run before sending an e-mail. The 'from', 'name', 'subject', +or 'message' field will be sent to the code references (depending on which method called) +and whatever is returned will be used as the actual field for the email sent. This can be +used to parse fields to customize them for each recipient. The subroutine is called with +two arguments: (ID_OR_EMAIL, FIELD). If an ID is provided, it will be passed as the +first argument, otherwise the email address will be passed. The second argument is the +field itself. The field used in the actual email to the user will be the value returned by +the subroutine. + +The default field (for the rest of the mailing) can be changed by directly modifying $_[1] +itself. + +If the subroutine reference returns an undefined value, the mailer will use the actual field +instead. You can use this technique to only modify some messages, but not others. + +Optional. + +=item show_errors + +If set to something true it will warn() on all errors. Optional. The default is turned on, +but can easily be changed by modifying the line ' + +=item error_code + +Takes a code reference - the code reference will be called with the error as the argument +when an error occurs. Optional. + +=item send + +Takes any number of the following arguments: + +=over 8 + +=item array reference + +An array reference of a list of e-mail addresses to send to. After each message, either the +success or failure callback will be called with the e-mail address as the argument, and +possibly a message as the second argument. + +=item hash reference + +A hash reference of ID =E email pairs. For example, +123 =E 'someone@whoknows.com'. The value will be used as the e-mail address to send +to, and the key will be an identifier to pass into the success or failure callbacks. + +=item glob reference + +A glob reference to an open file. Make sure the file is opened before passing this! +The file should contain one e-mail address per line. + +=item subroutine or code reference + +You may pass a code reference, and it will be called for each e-mail address. It is +assumed that the subroutine will return one e-mail address each time called, and +that a return value of "undef" indicates that there are no more e-mail addresses. +The code reference could alternatively return two items - if it does, it is assumed that +the first is an ID code, and that the second is the email address. When a call to either +or the success or failure callbacks, the ID will be provided as the first argument +instead of the e-mail address itself. + +One cool feature to note about using code refs is that you can call next() from within +the code reference and it will then recall the code reference for the next value. + +=cut diff --git a/site/glist/lib/GT/Mail/Editor.pm b/site/glist/lib/GT/Mail/Editor.pm new file mode 100644 index 0000000..94598de --- /dev/null +++ b/site/glist/lib/GT/Mail/Editor.pm @@ -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("
        \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 "
        \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: + To: + Subject: + Other headers:
        +
        +~; + 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~ +<$FONT>Pre Install Message:
        <$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~
        +<$FONT>Post Install Message:<$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~ +<$FONT>Install Code:<$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~ +<$FONT>Uninstall Code:<$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~ +~; + return $output; +} + +sub install_as_form { +# ---------------------------------------------------------------- +# Returns the install information as a form. +# + my $self = shift; + $self->_load_install; + my $output = qq~ +<$FONT>Pre Install Message:
        + <$FONT> +<$FONT>Post Install Message:
        + <$FONT> +<$FONT>Install Code:
        + <$FONT> +<$FONT>Uninstall Code:
        + <$FONT> +~; + 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~ +<$FONT>$hook_name ($prepost)<$FONT>$code + ~; + } + } + else { + $output = qq~ +<$FONT>No hooks installed + ~; + } + return $output; +} + +sub hooks_as_form { +# ---------------------------------------------------------------- +# Returns plugin hooks as form. +# + my $self = shift; + my $output; + if (@{$self->{hooks}}) { + $output = qq~ +<$FONT>Installed Hooks + ~; + my $i = 0; + foreach my $hook (@{$self->{hooks}}) { + my ($hook_name, $prepost, $code) = @$hook; + $output .= qq~ +<$FONT>$hook_name ($prepost) => $code<$FONT>Delete: + ~; + $i++; + } + } + my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::"; + $output .= qq~ +<$FONT>Add New Hook +<$FONT>Hook: + <$FONT>Code: + ~; + 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~ +<$FONT>$menu_name<$FONT>=> $menu_url + ~; + } + } + else { + $output = qq~ +<$FONT>No Admin Menu options installed + ~; + } + return $output; +} + +sub admin_menu_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (@{$self->{admin_menu}}) { + $output = qq~ +<$FONT>Installed Admin Menu options + ~; + 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~ +<$FONT>$menu_name => $menu_url<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Menu +<$FONT>Name: + <$FONT>URL: + ~; + 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~ +<$FONT>~ . _escape_html($key) . qq~<$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~ + ~; + } + } + else { + $output = qq~ +<$FONT>No user options installed + ~; + } + return $output; +} + +sub options_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (keys %{$self->{options}}) { + $output = qq~ +<$FONT>Installed User options + ~; + my $i = 0; + foreach my $key (sort keys %{$self->{options}}) { + $output .= qq~ +<$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Option +<$FONT>Name: + <$FONT>Default: + ~; + 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~ +<$FONT>$name<$FONT>$size + ~; + $num_files++; + } + } + if (! $num_files) { + $output = qq~ +<$FONT>No extra files installed + ~; + } + 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~ +<$FONT>$name<$FONT>($size) + ~; + $num_files++; + } + } + if ($num_files) { + $output = qq~ +<$FONT>Installed Files +$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 = <{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; + 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; diff --git a/site/glist/lib/GT/Plugins/Installer.pm b/site/glist/lib/GT/Plugins/Installer.pm new file mode 100644 index 0000000..c07a2c6 --- /dev/null +++ b/site/glist/lib/GT/Plugins/Installer.pm @@ -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 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 returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_menu + +C 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 returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_options + +C 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 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 diff --git a/site/glist/lib/GT/Plugins/Manager.pm b/site/glist/lib/GT/Plugins/Manager.pm new file mode 100644 index 0000000..a9c3d93 --- /dev/null +++ b/site/glist/lib/GT/Plugins/Manager.pm @@ -0,0 +1,1170 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : +# $Id: Manager.pm,v 1.61 2005/04/14 07:43:09 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to manage installed and uninstalled +# plugins. +# + +package GT::Plugins::Manager; +# ================================================================== +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.61 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + cfg => undef, + cgi => undef, + tpl_root => '.', + tpl_prefix => '', + prefix => '', + plugin_dir => undef, + plugin => undef, + plugin_name => undef, + tar => undef, + prog_ver => undef, + prog_reg => undef, + prog_name => undef, + # The program init (e.g. admin) path; if set, this is passed to the plugin + # server and also changes the way download_gossamer() returns errors: + prog_init => undef, + prog_user_cgi => undef, + prog_admin_cgi => undef, + prog_images => undef, + prog_libs => undef, + base_url => undef, + func_url => undef, + path_to_perl => undef, + perl_args => 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}); +} + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to manager"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_man_do') || ''; + my $vars = {}; + my $page = 'plugin_manager_list.html'; + + CASE: { + ($action eq 'pre_install') and do { + $vars = $self->pre_install; + $page = 'plugin_manager_pre_install.html'; + last CASE; + }; + ($action eq 'install') and do { + $vars = $self->install; + last CASE; + }; + ($action eq 'pre_uninstall') and do { + $vars = $self->pre_uninstall; + $page = 'plugin_manager_pre_uninstall.html'; + last CASE; + }; + ($action eq 'uninstall') and do { + $vars = $self->uninstall; + last CASE; + }; + ($action eq 'pre_delete') and do { + $page = 'plugin_manager_delete.html'; + last CASE; + }; + ($action eq 'delete') and do { + $vars = $self->delete; + last CASE; + }; + ($action eq 'hooks') and do { + $vars = $self->set_hooks; + $page = 'plugin_manager_hooks.html'; + last CASE; + }; + ($action eq 'edit_installed') and do { + $vars = $self->edit_installed; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit.html'; + last CASE; + }; + ($action eq 'edit_uninstalled') and do { + $vars = $self->edit_uninstalled; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit_files.html'; + last CASE; + }; + ($action eq 'download') and do { + $page = 'plugin_manager_download.html'; + last CASE; + }; + ($action eq 'download_gossamer') and do { + $page = 'plugin_manager_download.html'; + $vars = $self->download_gossamer; + last CASE; + }; + ($action eq 'download_url') and do { + $vars = $self->download_url; + last CASE; + }; + ($action eq 'download_file') and do { + $vars = $self->download_file; + last CASE; + }; + }; + if ($page eq 'plugin_manager_list.html') { + $vars->{installed} = $self->installed_plugins_html; + $vars->{uninstalled} = $self->uninstalled_plugins_html; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + foreach my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +# ------------------------------------------------------------------------------------------------- # +# Installing/Uninstalling Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub pre_install { +# ---------------------------------------------------------------- +# Display pre-installation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => $GT::Plugins::error }; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return { error => $GT::Plugins::error }; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $pre_code; + { + no strict 'refs'; + $pre_code = ${$plugin_pkg . '::'}{'pre_install'}; + } + my $message = 'No pre installation message supplied.'; + if (defined $pre_code and defined &{$pre_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $pre_code->(); + }; + if ($@) { + $message = "Error running installation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + $message = ${$plugin_pkg . "::error"} || "No error message provided."; + } + } + +# Check for overwriting. + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + if (-e $install_to) { + my $old_plugin = $self->installed_plugin_info($plugin_name); + my $old_version = $old_plugin ? $old_plugin->{version} : "(Can't load installed: $GT::Plugins::error)"; + my $new_plugin = $self->uninstalled_plugin_info($plugin_name); + my $new_version = $new_plugin ? $new_plugin->{version} : "(Can't load uninstalled: $GT::Plugins::error)"; + + return { instructions => $message, old_version => $old_version, new_version => $new_version, confirm => 1 }; + } + else { + return { instructions => $message }; + } +} + +sub install { +# ---------------------------------------------------------------- +# Install the plugin. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_inst = $self->{cgi}->param('skip_install'); + + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + +# Get the main code, and save it. + my $plugin_code = $tar->get_file("$plugin_name.pm") or return { error => "Unable to locate the $plugin_name.pm file in tar" }; + +# Save the code. + open (FILE, "> $install_to") or return { error => "Unable to create plugin file: $install_to. Reason: $!" }; + print FILE $plugin_code->body_as_string; + close FILE; + +# Add the plugin to the config. + delete $self->{cfg}->{$plugin_name}; + + $self->{cfg}->{$plugin_name}->{meta} = $plugin->{meta}; + $self->{cfg}->{$plugin_name}->{version} = $plugin->{version}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Run the install code if requested. + my ($message, $error); + + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $code; + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{install}; + } + if ($self->{cgi}->param('skip_install')) { + $message = "Installation code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $code->($installer, $tar); + }; +# Oh, oh, didn't install properly. + if ($@) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + return { error => "Error running installation code: $@" }; + } + if (! defined $message) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + no strict 'refs'; + $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided. ($@)"; + return { error => "Unable to install plugin: '$message'" }; + } + } + else { + $message = "No installation code found."; + } + +# Move the tar file to the Installed directory. + my $move_from = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + $tar->close_tar; # Need to close the tar file. + + rename($move_from, $move_to) or return { error => "Unable to move plugin from $move_from => $move_to ($!)" }; + +# Installed ok, return results. + if ($error) { + return { error => $error, reload => 1 }; + } + else { + my $output = qq~ +

        Plugin $plugin_name Installed
        +The plugin has been successfully installed.

        +Installation Notes:
        +$message +

        + ~; + return { results => $output, reload => 1 }; + } +} + +sub pre_uninstall { +# ---------------------------------------------------------------- +# Display pre-uninstallation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Installed') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $post_code; + { + no strict 'refs'; + $post_code = ${$plugin_pkg . '::'}{'pre_uninstall'}; + } + my $message = 'No pre uninstallation message supplied.'; + if (defined $post_code and defined &{$post_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $post_code->(); + }; + if ($@) { + $message = "Error running uninstallation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + my $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided."; + } + } + return { instructions => $message }; +} + +sub uninstall { +# ---------------------------------------------------------------- +# Display uninstallation message. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_uninst = $self->{cgi}->param('skip_uninstall'); + my $remove_from = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + my $tar = $self->_open_tar($plugin_name, 'Installed'); + my $move_from = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + if (! $tar) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink($remove_from); + return { error => "Unable to load tar file: $GT::Plugins::error" }; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + if (! $plugin) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $tar->close_tar; + unlink($remove_from); + rename($move_from, $move_to); + return { error => "Unable to load uninstall file: $GT::Plugins::error" }; + } + +# Run any uninstallation code. + my ($code, $output, $error); + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{uninstall}; + } + if ($self->{cgi}->param('skip_uninstall')) { + $output = "Uninstall code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + + local ($@, $SIG{__DIE__}, $^W); + eval { + $output = $code->($installer, $tar); + }; + if ($@) { + $error = "Error in uninstall code: $@"; + } + if (! $output and ! $error) { + $output = "Uninstall completed."; + } + } + else { + $output = "No uninstall code found."; + } + +# Remove the plugin from the config. + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Remove the .pm file. + unlink($remove_from) or return { error => "Unable to remove tar file: $remove_from. Reason: $!" }; + +# Move the tar file back to the Uninstalled directory. + $tar->close_tar; # Need to close the tar file. + rename($move_from, $move_to) or return { error => "Unable to place plugin back into Uninstalled directory: $move_from => $move_to ($!)" }; + + return { results => $output, reload => 1, error => $error }; +} + +# ------------------------------------------------------------------------------------------------- # +# Editing Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub edit_installed { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + if (! exists $self->{cfg}->{$plugin_name}) { + return { error => "Invalid plugin name: $plugin_name" }; + } + +# Update the plugin if requested. + my ($results, $reload); + if ($self->{cgi}->param('edit')) { + my %enabled_hooks = map { $_ => 1 } $self->{cgi}->param('hooks'); + my %enabled_menu = map { $_ => 1 } $self->{cgi}->param('menu'); + if (ref $self->{cfg}->{$plugin_name}->{hooks} eq 'ARRAY') { + my $i = 0; + foreach my $hook (@{$self->{cfg}->{$plugin_name}->{hooks}}) { + $hook->[3] = exists $enabled_hooks{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{menu} eq 'ARRAY') { + my $i = 0; + foreach my $menu (@{$self->{cfg}->{$plugin_name}->{menu}}) { + $menu->[2] = exists $enabled_menu{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{user} eq 'ARRAY') { + + my %opts; + foreach my $option ( @{$self->{cfg}->{$plugin_name}->{user} || []} ) { + $opts{$option->[0]} = $option; + } + + foreach my $key ($self->{cgi}->param()) { + next if ($key !~ /^user-(.+)/); + my $real_key = $1; + my @values = $self->{cgi}->param($key); +# find out if the item is a checkbox, if it is, make sure that it's an arrayref + my $val = (uc($opts{$real_key}->[3]) eq 'CHECKBOX') ? [@values] : $values[0]; + foreach my $opt (@{$self->{cfg}->{$plugin_name}->{user}}) { + if ($opt->[0] eq $real_key) { + $opt->[1] = $val; + } + } + } + } + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $results = "Plugin updated successfully."; + $reload = 1; + } + my $plugin = $self->{cfg}->{$plugin_name}; + my $hooks = $self->load_hooks($plugin_name); + my $menu = $self->load_menu($plugin_name); + my $opts = $self->load_options($plugin_name); + + return { hooks => $hooks, menu => $menu, options => $opts, %{$plugin->{meta}}, results => $results, reload => $reload }; +} + +sub edit_uninstalled { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => "Unable to open tar file: $GT::Plugins::error" }; + my $base = $self->{base_url}; + my ($output, $results, $body, $body_name); + + my $error = ''; + my $delete = $self->{cgi}->param('delete'); + if ($delete) { + $tar->remove_file($delete); + $tar->write ? ($results = "File $delete has been successfully removed!") : ($error = "Unable to delete file: $GT::Tar::error"); + } + my $add = $self->{cgi}->param('add'); + if ($add) { + my $body = $self->{cgi}->param('filebody'); + $tar->add_data(name => $add, body => $body); + $tar->write ? ($results = "File $add successfully added.") : ($error = "Unable to add file: $GT::Tar::error"); + } + my $edit = $self->{cgi}->param('edit'); + if ($edit) { + my $file = $tar->get_file($edit); + if ($file) { + $body = $file->body_as_string; + $body = $self->{cgi}->html_escape($body); + $body_name = $file->name; + } + } + my $save = $self->{cgi}->param('save'); + if ($save) { + my $file = $tar->get_file($save); + if ($file) { + my $body = $self->{cgi}->param('body'); + $body =~ s/\r//g; + $file->body($body); + $tar->write ? ($results = "File $save updated successfully.") : ($error = "Unable to save file: $GT::Tar::error"); + } + } + my $perl = $self->{cgi}->param('perl'); + if ($perl) { + my $file = $tar->get_file($perl); + if ($file) { + $results = $self->_syntax_check($file); + } + } + my $files = $tar->files; + + foreach my $file (@$files) { + my $name = $file->name; + next if ($name eq 'Wizard.pm'); + my $size = length $file->body_as_string; + + $output .= qq~ +$name ($size bytes) + + Edit | + Perl Check + ~; + $output .= qq~ + | Delete + ~ if (($name ne 'Install.pm') and ($name ne $plugin_name . '.pm')); + $output .= qq~ + + + ~; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or ($error = "Unable to load install file: $GT::Plugins::error"); + $plugin->{meta} ||= {}; + $plugin->{meta}->{title} ||= $plugin_name; + $plugin->{meta}->{author} ||= 'Unknown'; + $plugin->{meta}->{url} ||= ''; + $plugin->{meta}->{description} ||= ''; + $plugin->{version} ||= 'Unknown'; + return { files => $output, %{$plugin->{meta}}, results => $results, body => $body, body_name => $body_name, inst_error => $error }; +} + +sub load_menu { +# ----------------------------------------------------------------- +# Returns the html to enable/disable admin menu options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{menu} eq 'ARRAY'); + my $output = qq~ +Menu Options (show/hide) + ~; + my $i = 0; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + my ($menu, $url, $enabled) = @$menu_option; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $menu + ~; + $i++; + } + return $output; +} + +sub load_hooks { +# ----------------------------------------------------------------- +# Returns the html to enable/disable hooks. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{hooks} eq 'ARRAY'); + my $output = qq~ +Plugin Hooks (enable/disable) + ~; + my $i = 0; + + foreach my $hook (@{$self->{cfg}->{$plugin}->{hooks}}) { + my ($hookname, $prepost, $action, $enabled) = @$hook; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $hookname ($prepost) + ~; + $i++; + } + return $output; +} + +sub load_options { +# ----------------------------------------------------------------- +# Returns the html to enable/disable plugin options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{user} eq 'ARRAY'); + my $output = qq~ +Plugin Options + ~; + + # This may be changed in the future + require GT::SQL::Display::HTML; + my $HTML = GT::SQL::Display::HTML->new(); + foreach my $option (@{$self->{cfg}->{$plugin}->{user}}) { + my ($name, $val, $ins, $type, $names, $values ) = @$option; + + $type ||= 'text'; $type = lc( $type ); + my $options = {}; + foreach my $i ( 0 .. $#$names ) { $options->{ $values->[$i] } = $names->[$i]; } + + no strict 'refs'; + my $form_element = $HTML->$type( { name => "user-$name", value => $val, values => $options } ); + use strict; + + if ($ins) { + $output .= qq~$ins~; + } + + $output .= qq~ + + $name + $form_element + + ~; + +# if ($ins) { +# $output .= qq~$ins~; +# } +# +# $output .= qq~ +# +# $name +# +# +# ~; + } + + return $output; +} + +# ------------------------------------------------------------------------------------------------- # +# Removing Files # +# ------------------------------------------------------------------------------------------------- # + +sub delete { +# ---------------------------------------------------------------- +# Remove a plugin completely from the Uninstalled dir. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + return unlink($file) ? { results => "Plugin successfully removed." } : { error => "Unable to remove plugin: $file. Reason: $!" }; +} + +# ------------------------------------------------------------------------------------------------- # +# Downloading Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub download_gossamer { + my $self = shift; + + require GT::WWW; + require GT::Date; + + my $reg_number = $self->{prog_reg}; + my $url = "http://www.gossamer-threads.com/perl/updates/plugin.cgi"; + my $mh = 10; + my $nh = $self->{cgi}->param('nh') || 1; + my $beg = $nh == 1 ? 0 : $mh * ($nh - 1); + my $www = GT::WWW->new( + protocol => 'http', + host => 'www.gossamer-threads.com', + path => '/perl/updates/plugin.cgi', + parameters => [ + product => $self->{prog_name}, + product_version => $self->{prog_ver}, + reg_number => $reg_number, + sb => $self->{cgi}->param('sb') || 'plugin_name', + so => $self->{cgi}->param('so') || 'asc', + $self->{prog_init} ? (init_path => $self->{prog_init}) : (), + ] + ); + my $page = $www->get or return { error => "Unable to contact Gossamer Threads: " . $www->error() . ". Please try again later." }; + my @plugins = split /\n/, $page; + my $status_line = shift @plugins; + my ($status) = $status_line =~ /^# Status: (\w+)$/; + + if ($status ne 'ok') { + if (!$self->{prog_init}) { + # Old products - they only expect a single error tag containing the error message + return { error => "You are not authorized to connect to the plugin server. Please contact support\@gossamer-threads.com for more information and reference status: '$status'." }; + } + else { + # New programs just get the error_code and format their own message in the template. + # Error codes: + # admin_path_mismatch_reset - the stored admin path does not match; it can be reset from the license area + # admin_path_mismatch - the stored admin path does not match; no resets are available + # invalid_product_id - the 'product' provided is unknown by the plugin server + return { error_code => $status }; + } + } + + my $plugin_cfg = do "$self->{plugin_dir}/plugin.cfg" || {}; + my $count = 0; + my $hits = $#plugins + 1; + my (@output, $speedbar, $html); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ +
        + + + + + + + ~; + foreach my $p (@plugins) { + $count++; + next if $nh > 1 and $count < $beg + 1; + + my %row; + ($row{plg_id}, $row{plg_name}, $row{plg_version}, $row{plg_url}, $row{plg_support}, $row{plg_support_url}, $row{plg_language}, $row{plg_updated}, $row{plg_license}, $row{plg_price}, $row{plg_author}, $row{cli_id_fk}, $row{author_name}, $row{plg_description}) = split /\t/, $p; + $row{plg_updated} = GT::Date::date_get($row{plg_updated}, "%ddd%, %mmm% %dd% %yyyy% %hh%:%MM%:%ss%") if $row{plg_updated}; + + my $fetch = "$url/$row{plg_name}.tar?id=$row{plg_id};reg_number=$reg_number"; + $row{download_url} = $self->{cgi}->escape($fetch); + $row{installed} = $plugin_cfg->{$row{plg_name}} ? $plugin_cfg->{$row{plg_name}}->{version} : ''; + push @output, \%row; + + my $price = $row{plg_license} == 2 ? $row{plg_price} : 'Free'; + $output .= qq~ + + + + + + ~; + last if @output == $mh; + } + if ($hits > $mh) { + my $pages = int($hits / $mh); + $pages++ if $hits % $mh; + for my $i (1..$pages) { + $self->{cgi}->param('nh', $i); + my $url = $self->{cgi}->url; + $speedbar .= $i == $nh ? "$i " : "$i "; + } + } + $output = qq~ +

        <$font>There are $hits plugins available for download.

        + $speedbar + $output +
        <$font>Plugin Name<$font>Latest Version<$font>Action
        + <$font>$row{plg_name}
        + Author: $row{author_name}
        + Last Updated: $row{plg_updated}
        + Description:
        $row{plg_description}
        + Price: $price + +
        <$font>$row{plg_version}<$font>Download
        +
        + $speedbar + ~; + return { plugins => \@output, num_plugins => $hits, speedbar => $speedbar, base_url => $self->{base_url}, gossamer => $output }; +} + +sub download_file { +# ------------------------------------------------------------------- +# Place the upload file into the Uninstalled directory. +# + my $self = shift; + my $file = $self->{cgi}->param('file'); + if (! $file) { + return { error => "Please press browse to pick a file before uploading." }; + } + my ($name) = $file =~ m,([^/\\]+)$,; + if ($name !~ /^[\w\-\.]+\.tar$/) { + return { error => "Invalid file name: $name. Must be a .tar file, and only be letters and numbers, no spaces." }; + } + my $full_path = $self->{plugin_dir} . "/Uninstalled/" . $name; + open (FILE, "> $full_path") or return { error => "Unable to create file: $full_path ($!)" }; + binmode FILE; # Output stream + binmode $file; # Input stream + my ($read, $buffer); + while ($read = read($file, $buffer, 4096)) { + print FILE $buffer; + } + close FILE; + + return { results => "File was uploaded successfully." }; +} + +sub download_url { +# ------------------------------------------------------------------- +# Fetch a plugin from a URL and save it to the folder. +# + my $self = shift; + my $url = $self->{cgi}->param('url'); + $url or return { error => "Please enter a valid url." }; + require GT::WWW; + my ($protocol) = GT::WWW->parse_url($url); + return { error => "Invalid URL specified" } unless $protocol; + + unless (GT::WWW->protocol_supported($protocol)) { + return { error => "Unsupported protocol entered: $protocol" }; + } + + my ($fh, $plugin_file, $full_path, $plugin_error, $status_error, $open_error, $no_filename, $print_error); + my $www = GT::WWW->new($url); + $www->chunk_size(16 * 1024); # Get 16KB at a time + $www->chunk(sub { + my $chunk = shift; + unless ($fh or defined $plugin_error) { + my $response = $www->response; + my $status = $response->status; + my $header = $response->header; + if ($status_error = not $status) { + $www->cancel; + return; + } + if ($header->contains('X-Plugins' => 'Error')) { + $plugin_error = ''; + } + else { + $plugin_file = {$header->header_words('Content-Disposition')}->{filename}; + unless ($plugin_file) { + if (!$www->query_string) { + my $path = $www->path; + ($plugin_file) = $path =~ m{/([^/]+)\.tar$}; + $plugin_file .= ".tar" if $plugin_file; + } + unless ($plugin_file) { + $open_error = "No plugin found at url: $url"; + $no_filename = 1; + $www->cancel; + return; + } + } + $fh = \do { local *PLUGIN; *PLUGIN }; + $full_path = "$self->{plugin_dir}/Uninstalled/$plugin_file"; + unless (open $fh, "> $full_path") { + $open_error = "Unable to create file '$full_path': $!"; + $www->cancel; + return; + } + binmode $fh; + } + } + if (defined $plugin_error) { $plugin_error .= $$chunk } + else { + unless (print $fh $$chunk) { + $print_error = "Unable to continue writing to file '$full_path': $!. Removing partial file."; + $www->cancel; + unlink $full_path; + } + } + }); + + my $response = $www->get or return { error => "Unable to retrieve plugin: " . $www->error }; + $status_error and return { error => "Unable to retrieve plugin: Server returned error status: " . (int $response->status) . $response->status }; + defined $plugin_error and return { error => $plugin_error }; + $open_error and return { error => $open_error }; + $print_error and return { error => $print_error }; + + return { results => "Plugin $plugin_file retrieved successfully." }; +} + +# ------------------------------------------------------------------------------------------------- # +# Utilities # +# ------------------------------------------------------------------------------------------------- # + +sub admin_menu { +# ---------------------------------------------------------------- +# Displays the admin menu. +# + my $self = shift; + my $menu = ''; + foreach my $plugin (sort keys %{$self->{cfg}}) { + next unless ($self->{cfg}->{$plugin}->{menu}); + $menu .= qq~ + +  $plugin
        + ~; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + next if (defined $menu_option->[2] and ! $menu_option->[2]); + $menu .= qq~  
        $menu_option->[0]
        ~; + } + $menu .= " "; + } + if ($menu) { + $menu = qq~ + +  Installed + Plugins + + $menu + ~; + } + return $menu; +} + +sub installed_plugins { +# ---------------------------------------------------------------- +# Returns a list of installed plugins, not formatted. +# + my $self = shift; + my $plgs = {}; + foreach my $plugin (keys %{$self->{cfg}}) { + next if (substr($plugin, 0, 1) eq '_'); + $plgs->{$plugin} = $self->{cfg}->{$plugin}; + } + return $plgs; +} + +sub installed_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of installed plugins. +# + my $self = shift; + my $plugins = $self->installed_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; +# Show installed plugins. + my $base = $self->{base_url}; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Installed Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title<$font>$version<$font>$author<$font>Edit | + Uninstall
        "; + if (! $count) { + $html = "
        No plugins have been installed.
        "; + } + return $html; +} + +sub uninstalled_plugins { +# ---------------------------------------------------------------- +# Returns a list of uninstalled plugins, not formatted. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!); + while (defined(my $file = readdir(DIR))) { + next unless ($file =~ /^(.+)\.tar$/); + my $plugin_name = $1; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled'); + $tar or $plugins{$plugin_name} = { tar_error => $GT::Plugins::error } and next; + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + $plugin or $plugins{$plugin_name} = { inst_error => $GT::Plugins::error } and next; + $plugins{$plugin_name} = $plugin; + } + closedir(DIR); + return \%plugins; +} + +sub uninstalled_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of uninstalled plugins. +# + my $self = shift; + my $plugins = $self->uninstalled_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; + my $base = $self->{base_url}; + my $func = $self->{func_url} ? $self->{func_url} : "$base&do=plugin"; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + my $tar_err = $plugin->{tar_error} || ''; + my $inst_err = $plugin->{inst_error} || ''; + my $inst_l = qq~Install |~; + my $edit_l = qq~Edit |~; + my $error = ''; + if ($tar_err) { + $error = "
        $tar_err"; + $inst_l = ''; + $edit_l = ''; + } + if ($inst_err) { + $error = "
        $inst_err"; + $inst_l = ''; + } + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Uninstalled Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title$error<$font>$version<$font>$author<$font>$inst_l $edit_l + Delete + | Download
        "; + if (! $count) { + $html = "
        No plugins are available to be installed.
        "; + } + return $html; +} + +sub uninstalled_plugin_info { +# ---------------------------------------------------------------- +# Returns a hash of plugin info for an uninstalled plugin. +# + my ($self, $plugin_name) = @_; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + if (! -e $file) { + return $self->error('CANTOPEN', 'WARN', $file, $!); + } + my $tar = GT::Tar->open($file) or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + return $plugin; +} + +sub installed_plugin_info { +# ---------------------------------------------------------------- +# Return a hash of plugin info for an installed plugin. +# + my ($self, $plugin_name) = @_; + return exists $self->{cfg}->{$plugin_name} ? + $self->{cfg}->{$plugin_name} : + $self->error('NOPLUGIN', 'WARN', $plugin_name); +} + +sub _open_tar { +# ---------------------------------------------------------------- +# Opens a tar file. +# + my ($self, $plugin_name, $dir) = @_; + my $file = $self->{plugin_dir} . '/' . $dir . '/' . $plugin_name . '.tar'; + if (! -e $file) { + return $self->error('CANTLOAD', 'WARN', $file, $!); + } + my $tar = GT::Tar->open( $file ) or return $self->error('CANTLOAD', 'WARN', $file, "Unable to parse tar file: $GT::Tar::error"); + return $tar; +} + +sub _load_plugin_install { +# ---------------------------------------------------------------- +# Takes a .tar file, looks for an Install.pm file, evals it, and +# returns a hash of meta info. +# + my ($self, $tar, $plugin_name) = @_; + my $install = $tar->get_file('Install.pm') or return $self->error('CANTLOAD', 'WARN', $plugin_name, "No Install.pm file found in tar!"); + +# Eval the install file. + my $file = $install->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $plugin_name, "Install.pm does not compile: $@"); + } + } + +# Load the meta info. + no strict 'refs'; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + my $version = ${$plugin_pkg . "::VERSION"}; + + my $meta = defined ${$plugin_pkg . '::META'} ? ${$plugin_pkg . '::META'} : {}; + if (! defined $version) { + $version = defined $meta->{version} ? $meta->{version} : 'UNKNOWN'; + } + my $author = defined $meta->{author} ? $meta->{author} : 'Unknown'; + my $url = defined $meta->{url} ? $meta->{url} : 'Unknown'; + my $desc = defined $meta->{description} ? $meta->{description} : 'None'; + + return { name => $plugin_name, meta => $meta, author => $author, url => $url, description => $desc, version => $version }; +} + +sub _syntax_check { +# ------------------------------------------------------------------- +# Returns the output of syntax checking the current file. +# + my $self = shift; + my $file = shift; + my $results; + + require GT::TempFile; + if ($self->{path_to_perl} and -x $self->{path_to_perl}) { + my $tmp_file = new GT::TempFile; + open (TMPFILE, "> $$tmp_file") or return "Couldn't open temp file: $$tmp_file ($!)"; + print TMPFILE $file->body_as_string; + close TMPFILE; + + my $args = $self->{perl_args} || ''; + +# We are not really running under mod_perl in the spawned perl check. +# DBI will not load if it thinks we are (but aren't). + local($ENV{GATEWAY_INTERFACE}, $ENV{MOD_PERL}); + my $perl_results = `$self->{path_to_perl} $args $$tmp_file 2>&1`; + my $filename = $file->name; + $perl_results =~ s/$$tmp_file/$filename/g; + + $results = "Perl Said:
        $perl_results
        "; + } + else { + $results = "Unable to execute perl: $self->{path_to_perl}"; + } + return $results; +} + +1; + diff --git a/site/glist/lib/GT/Plugins/Wizard.pm b/site/glist/lib/GT/Plugins/Wizard.pm new file mode 100644 index 0000000..2621771 --- /dev/null +++ b/site/glist/lib/GT/Plugins/Wizard.pm @@ -0,0 +1,1098 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : +# $Id: Wizard.pm,v 1.34 2005/04/14 07:43:48 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to install/uninstall/edit plugins. +# + +package GT::Plugins::Wizard; +# ================================================================== +use strict; +use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/; +use GT::Base; +use GT::Plugins; +use GT::Tar; +use GT::Dumper; + +$ERROR_MESSAGE = 'GT::Plugins'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + prefix => '', + cgi => undef, + initial_indent => ' ', + tpl_root => '.', + tpl_prefix => '', + plugin_dir => undef, + plugin => undef, + tar => undef, + prog_ver => undef, + install_header => undef, + dirs => {}, + oo => undef +}; +@ISA = qw/GT::Base/; + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to wizard"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to wizard"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_wiz_do') || ''; + my $vars = {}; + my $page = 'plugin_wizard_step1.html'; + my $plugin = $self->{cgi}->param('plugin_name'); + $self->load_plugin($plugin) if ($plugin); + + CASE: { +# Meta Information + ($action eq 'step2') and do { + $vars = $self->_validate_step1(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step1.html'; last CASE } + $vars = $self->_load_step2(); + $page = 'plugin_wizard_step2.html'; + last CASE; + }; +# Plugin Hooks + ($action eq 'step3') and do { + $vars = $self->_validate_step2() unless ($self->{cgi}->param('skip_validate')); + if (defined $vars->{error}) { $page = 'plugin_wizard_step2.html'; last CASE } + $vars = $self->_load_step3(); + $page = 'plugin_wizard_step3.html'; + last CASE; + }; +# Admin Menu Options. + ($action eq 'step4') and do { + $vars = $self->_validate_step3(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step3.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step3.html'; last CASE } + $vars = $self->_load_step4(); + $page = 'plugin_wizard_step4.html'; + last CASE; + }; +# User Options. + ($action eq 'step5') and do { + $vars = $self->_validate_step4(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step4.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step4.html'; last CASE } + $vars = $self->_load_step5(); + $page = 'plugin_wizard_step5.html'; + last CASE; + }; +# Included Files. + ($action eq 'step6') and do { + $vars = $self->_validate_step5(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step5.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step5.html'; last CASE } + $vars = $self->_load_step6(); + $page = 'plugin_wizard_step6.html'; + last CASE; + }; +# All Done. + ($action eq 'step7') and do { + $vars = $self->_validate_step6(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step6.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step6.html'; last CASE } + $vars = $self->_load_step7(); + $page = 'plugin_wizard_step7.html'; + last CASE; + }; +# Create the plugin and finish. + ($action eq 'create') and do { + $vars = $self->_validate_step7(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_install(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_code(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $page = 'plugin_wizard_step8.html'; + last CASE; + }; + +# Get a list of plugins that can be edited. + $vars->{edit} = $self->_list_editable; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + for my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +sub load_plugin { +# ---------------------------------------------------------------- +# Loads a plugin. +# + my ($self, $plugin_name) = @_; + $self->{plugin}->{name} = $plugin_name; + return unless (defined $plugin_name and $plugin_name =~ /^\w{2,20}$/); + + $self->{tar} = $self->_load_tar; + $self->_load_plugin; + return 1; +} + +sub save_plugin { +# ------------------------------------------------------------------- +# Saves the plugin back to disk. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm'); + if (! $wizard) { + $self->{tar}->add_data(name => 'Wizard.pm', body => $self->_create_wizard); + } + else { + $wizard->body($self->_create_wizard); + } + return $self->{tar}->write; +} + +sub _get_hook_params { +# ------------------------------------------------------------------------------ + my $hook = shift; + my $param = shift; + my %results; + for my $e (@$hook) { + my $val = ref $e->{$param} ? join(", ", @{$e->{$param}}) : $e->{$param}; + $results{$val}++; + } + return sort keys %results; +} + +sub _validate_step1 { +# ------------------------------------------------------------------- +# Checks that the plugin name is valid. +# + my $self = shift; + my $name = $self->{cgi}->param('plugin_name'); + $name or return { error => "Please enter a valid plugin name." }; + $name =~ /^\w{2,20}$/ or return { + error => "Plugin names must be only letters and numbers, and be between 2 and 20 characters." + }; + $self->save_plugin or return { error => $GT::Plugins::error }; + return { plugin_name => $name }; +} + +sub _load_step2 { +# ------------------------------------------------------------------- +# Preloads vars for meta information. +# + my $self = shift; + return defined $self->{plugin}->{meta}->{prog_ver} + ? $self->{plugin}->{meta} + : { %{$self->{plugin}->{meta}}, prog_ver => $self->{prog_ver} }; +} + +sub _validate_step2 { +# ------------------------------------------------------------------- +# Validates the meta information. +# + my $self = shift; + my $version = $self->{cgi}->param('version'); + $version or return { error => "Please make sure you enter a version, perhaps start with 0.0.1 to begin." }; + $version =~ /^[\d\.]+$/ or return { error => "Version numbers should contain only numbers and periods." }; + + my $author = $self->{cgi}->param('author'); + $author or return { error => "Please make sure you enter an author." }; + + my $url = $self->{cgi}->param('url'); + + my $license = $self->{cgi}->param('license'); + $license or return { error => "Please make sure you enter in a license style." }; + + my $prog_ver = $self->{cgi}->param('prog_ver'); + $prog_ver or return { + error => 'Please enter a program version that your plugin will require. Set to 1 for all versions. ' . + 'This is useful to ensure the plugin user has the required version before using the plugin.' + }; + + my $description = $self->{cgi}->param('description'); + + $self->{plugin}->{meta} = { + version => $version, + author => $author, + url => $url, + license => $license, + description => $description, + prog_ver => $prog_ver + }; + + $self->save_plugin or return { error => $GT::Plugins::error }; + + return {}; +} + +sub _load_step3 { +# ------------------------------------------------------------------- +# Preloads vars for hook information. +# + my $self = shift; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + +# try to load the hook config file + return { hooks => '' } unless defined $self->{plugin}->{hooks} and @{$self->{plugin}->{hooks}}; + + my $output = qq~ + + + + + + ~; + + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + my ($name, $type, $code, $position) = @$hook; + $output .= qq~ + + + + + + ~; + } + $output .= qq~ +
        <$font>Hook<$font>Type<$font>Code<$font>Position
        <$font> $name<$font>$type<$font>$code<$font>$position
        + ~; + return { hooks => $output }; +} + +sub _validate_step3 { +# ------------------------------------------------------------------- +# Validate any new hooks that were added. +# + my $self = shift; + $self->{plugin}->{hooks} ||= []; + +# Remove unwanted hooks. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + if ($id eq $del_id) { + $results .= "
      • Plugin hook " . $hook->[0] . " successfully removed."; + splice @{$self->{plugin}->{hooks}}, $i, 1; + } + $i++; + } + } + } +# Add new hooks + my $add_hook = $self->{cgi}->param('name'); + if ($add_hook) { + my $add_code = $self->{cgi}->param('code'); + my $add_type = $self->{cgi}->param('type'); + my $add_pos = $self->{cgi}->param('pos'); # Not used; future use? + push @{$self->{plugin}->{hooks}}, [$add_hook, $add_type, $add_code, $add_pos]; + $results .= "
      • Plugin hook $add_hook successfully added."; + } + my $hooks = $self->_load_step3; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", hooks => $hooks->{hooks} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more hooks to delete.", hooks => $hooks->{hooks} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, hooks => $hooks->{hooks} }; + } + return {}; +} + +sub _load_step4 { +# ------------------------------------------------------------------- +# Preloads vars for admin menu options. +# + my $self = shift; + return { menu => '' } unless $self->{plugin}->{menu} and @{$self->{plugin}->{menu}}; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Name<$font>URL
        <$font> $name<$font>$url
        + ~; + return { menu => $output }; +} + +sub _validate_step4 { +# ------------------------------------------------------------------- +# Validate any new menu that were added. +# + my $self = shift; + $self->{plugin}->{menu} ||= []; + +# Remove unwanted menu. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + if ($name eq $del_id) { + splice @{$self->{plugin}->{menu}}, $i, 1; + $results .= "
      • Menu Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new menu + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_url = $self->{cgi}->param('url'); + $self->{plugin}->{menu} ||= []; + push @{$self->{plugin}->{menu}}, [$add_name, $add_url]; + $results .= "
      • Menu Option $add_name successfully added."; + } + + my $menu = $self->_load_step4; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", menu => $menu->{menu} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more admin menu to delete.", menu => $menu->{menu} }; + } + + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, menu => $menu->{menu} }; + } + return {}; +} + +sub _load_step5 { +# ------------------------------------------------------------------- +# Preloads vars for user options. +# + my $self = shift; + return { user => '' } unless (defined $self->{plugin}->{user} and @{$self->{plugin}->{user}}); + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + + + + + ~; + + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $instructions, $form_type, $form_names, $form_values ) = @$opt; + $form_values = @$form_values + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_values) . "
        " + : " "; + $form_names = @$form_names + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_names) . "
        " + : " "; + my $ins = $self->{cgi}->html_escape($instructions); + $val = $self->{cgi}->html_escape($val); + $output .= qq~ + + + + + + + + +~; + } + $output .= qq~
        <$font>Name<$font>Value<$font>Instructions<$font>Form Type<$font>Form Names<$font>Form Value
        <$font> $name<$font>$val<$font>$ins <$font>$form_type<$font>$form_names<$font>$form_values
        ~; + + return { user => $output }; +} + +sub _validate_step5 { +# ------------------------------------------------------------------- +# Validate any user options that were added. +# + my $self = shift; + $self->{plugin}->{user} ||= []; + +# Remove unwanted user options. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $ins) = @$opt; + if ($name eq $del_id) { + splice @{$self->{plugin}->{user}}, $i, 1; + $results .= "
      • User Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new user option + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_val = $self->{cgi}->param('value'); + my $add_ins = $self->{cgi}->param('instructions'); + my $form_names = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_names') ]; + my $form_values = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_values') ]; + my $form_type = $self->{cgi}->param('form_type'); + push @{$self->{plugin}->{user}}, [ $add_name, $add_val, $add_ins, $form_type, $form_names, $form_values ]; + $results .= "
      • User Option $add_name successfully added."; + } + my $user = $self->_load_step5; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", user => $user->{user} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more user option to delete.", user => $user->{user} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, user => $user->{user} }; + } + return {}; +} + +sub _load_step6 { +# ------------------------------------------------------------------- +# Preloads any user included files. +# + my $self = shift; + return { files => '' } unless (defined $self->{plugin}->{files} and @{$self->{plugin}->{files}}); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + my %seen; + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $location) = @$file; + my $id = join("|", @$file); + next if $name eq "$self->{plugin}->{name}.pm"; + if (exists $self->{dirs}->{$location}) { + $location = $self->{dirs}->{$location}; + } + $seen{$name}++; + $output .= qq~ + + + + ~; + } + my $files = $self->{tar}->files; + for my $file (@$files) { + my $name = $file->name; + my $id = $name . '|'; + + next if $seen{$name} or $name eq 'Wizard.pm' or $name eq 'Install.pm' or $name eq "$self->{plugin}->{name}.pm"; + + push @{$self->{plugin}->{files}}, [$name, '']; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Filename<$font>Location
        <$font> $name<$font>$location
        <$font> $name<$font>Unknown (not added in Wizard)
        + ~; + return { files => $output }; +} + +sub _validate_step6 { +# ------------------------------------------------------------------- +# Receives files and stores them in the tar file. +# + my $self = shift; + my $results = ''; + $self->{plugin}->{files} ||= []; + +# Remove any existing files. + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $file (@{$self->{plugin}->{files}}) { + my $id = join("|", @$file); + if ($id eq $del_id) { + my $name = $file->[0]; + $self->{tar}->remove_file($name); + $self->{tar}->write; + splice @{$self->{plugin}->{files}}, $i, 1; + $results .= "
      • File " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add any new attachments. + my $filename = $self->{cgi}->param('name'); + if ($filename) { + my $filehandle = $self->{cgi}->param('file'); + my $body = $self->{cgi}->param('add_body'); + my $location = $self->{cgi}->param('location'); + if (ref $filehandle) { + $body = ''; + my ($buffer, $read); + while ($read = read($filehandle, $buffer, 4096)) { + $body .= $buffer; + } + } + $body ||= ' '; + $body =~ s/\r//g; + push @{$self->{plugin}->{files}}, [$filename, $location]; + my $res = $self->{tar}->add_data(name => $filename, body => $body); + $results .= "File $filename attached successfully."; + } + my $file = $self->_load_step6; + $self->save_plugin or return { error => $GT::Plugins::error }; + + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", files => $file->{files} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more file to delete.", files => $file->{files} }; + } + if ($results) { + return { results => $results, files => $file->{files} }; + } + return {}; +} + +sub _load_step7 { +# ------------------------------------------------------------------- +# Fetches the install/uninstall message. +# + my $self = shift; + return { + install => $self->{plugin}->{install}, + uninstall => $self->{plugin}->{uninstall}, + install_code => $self->{plugin}->{install_code}, + uninstall_code => $self->{plugin}->{uninstall_code} + }; +} + +sub _validate_step7 { +# ------------------------------------------------------------------- +# Saves the install/uninstall message. +# + my $self = shift; + $self->{plugin}->{install} = $self->{cgi}->param('install'); + $self->{plugin}->{uninstall} = $self->{cgi}->param('uninstall'); + $self->{plugin}->{install_code} = $self->{cgi}->param('install_code'); + $self->{plugin}->{uninstall_code} = $self->{cgi}->param('uninstall_code'); + $self->save_plugin or return { error => $GT::Plugins::error }; + return {}; +} + +sub _create_code { +# ------------------------------------------------------------------- +# Creates the code file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + $self->{install_header} ||= ''; + my $stubs = $self->_create_stubs; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== + +$self->{initial_indent}use strict; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +# Inherit from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +# Your code begins here. +$stubs + +# Always end with a 1. +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file($self->{plugin}->{name} . '.pm'); + if ($file) { + my $overwrite = $self->{cgi}->param('overwrite'); + my $skip = $self->{cgi}->param('skip'); + if (! $overwrite and ! $skip) { + return { error => "Overwrite the existing $self->{plugin}->{name}.pm:
        " }; + } + $file->body($output) if ($overwrite); + } + else { + $self->{tar}->add_data( name => $self->{plugin}->{name} . '.pm', body => $output ); + } + $self->{tar}->write; + return {}; +} + +sub _create_install { +# ------------------------------------------------------------------- +# Creates the install.pm file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + (my $qversion = $version) =~ s/(?=['\\])/\\/g; + + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{plugin}->{meta}); + my $inst_mess = GT::Dumper->dump(var => 'my $inst_msg', data => $self->{plugin}->{install}); + my $uninst_mess = GT::Dumper->dump(var => 'my $uninst_msg', data => $self->{plugin}->{uninstall}); + my $install = $self->_create_install_func; + my $uninstall = $self->_create_uninstall_func; + + for ($meta_dump, $inst_mess, $uninst_mess, $install, $uninstall) { s/\r//g } + + my $inst_code = $self->{plugin}->{install_code} || ''; + $inst_code =~ s/\r//g; + $inst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + my $uninst_code = $self->{plugin}->{uninstall_code} || ''; + $uninst_code =~ s/\r//g; + $uninst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + $self->{install_header} ||= ''; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== +$self->{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$VERSION \$DEBUG \$NAME \$META/; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +$self->{initial_indent}\$VERSION = '$qversion'; +$self->{initial_indent}\$DEBUG = 0; +$self->{initial_indent}\$NAME = '$self->{plugin}->{name}'; +# Inhert from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +$self->{initial_indent}$meta_dump + +sub pre_install { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they install the plugin. +# + $inst_mess + return \$inst_msg; +} + +sub pre_uninstall { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they remove the plugin. +# + $uninst_mess + return \$uninst_msg; +} + +sub install { +# ----------------------------------------------------------------------------- +# This function does the actual installation. Its first argument is a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. The second argument is a GT::Tar object which you can use to access any +# files in your plugin module. +# +# You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$Plugins::$self->{prefix}$self->{plugin}->{name}::error +# + my (\$mgr, \$tar) = \@_; + $install + $inst_code + return "The plugin has been successfully installed!"; +} + +sub uninstall { +# ----------------------------------------------------------------------------- +# This function removes the plugin. Its first argument is also a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$${plugin_pkg}::error +# + my \$mgr = shift; + $uninstall + $uninst_code + return "The plugin has been successfully removed!"; +} + +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file('Install.pm'); + if ($file) { + $file->body($output); + } + else { + $self->{tar}->add_data(name => 'Install.pm', body => $output); + } + $self->{tar}->write; + return {}; +} + +sub _esc { +# ------------------------------------------------------------------- + $_[0] =~ s/'/\\'/g; + $_[0] =~ s/\n/\\\n/g; + $_[0] =~ s/\r//g; + return; +} + +sub _create_install_func { +# ------------------------------------------------------------------- +# Creates the install function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + + $code .= qq~\n \$mgr->install_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~\n \$mgr->install_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + $code .= qq~\n \$mgr->install_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + if (@{$self->{plugin}->{files}}) { + $code .= qq~ + +# Silence warnings + \$GT::Tar::error ||= ''; + +# The following section will unarchive attached files into the proper location. + my \$file;~; + } + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $loc) = @$file; + next if ($name eq $self->{plugin}->{name} . '.pm'); + next if ($name eq 'Install.pm'); + my $path = ''; + if (exists $self->{dirs}->{$loc}) { + $path = $self->{dirs}->{$loc}; + } + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + $code .= qq~ + +# Copying $name to $path directory. + \$file = \$tar->get_file('$name'); + \$file->name("$path/$name"); + \$file->write or return $plugin_pkg->error("Unable to extract file '$path/$name': \$GT::Tar::error", 'WARN');~; + } + return $code; +} + +sub _create_uninstall_func { +# ------------------------------------------------------------------- +# Creates the uninstall function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + $code .= qq~\n \$mgr->uninstall_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~ \$mgr->uninstall_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + + $code .= qq~\n \$mgr->uninstall_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + return $code; +} + +sub _create_stubs { +# ------------------------------------------------------------------- +# Creates a subroutine stub for each hook. +# + my $self = shift; + my $code = ''; + if (@{$self->{plugin}->{hooks}}) { + $code .= qq~ + +# PLUGIN HOOKS +# =================================================================== +~; + } + my %seen; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $full_sub_name = $hook->[2]; + my ($sub_name) = $full_sub_name =~ /([^:]+)$/; + next if $seen{$sub_name}++; + my $hook_name = $hook->[0]; + $code .= qq~ + +sub $sub_name { +# ----------------------------------------------------------------------------- +# This subroutine will be called whenever the hook '$hook_name' is run. You +# should call @{[$self->{oo} || 'GT::Plugins']}->action(STOP) if you don't want the regular +# '$hook_name' code to run, otherwise the code will continue as normal. +# + my (\@args) = \@_; + +# Do something useful here + + return \@args; +}~; + } + if (@{$self->{plugin}->{menu}}) { + $code .= qq~ + +# ADMIN MENU OPTIONS +# =================================================================== +~; + } + %seen = (); + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; + my $val2 = $menu->[1]; + my ($func) = $val2 =~ /func=(\w+)/; + next if $seen{$func}++; + if ($func) { + $code .= qq~ +sub $func { +# ------------------------------------------------------------------- +# This subroutine will be called whenever the user clicks on '$val1' in the +# admin menu. Remember, you need to print your own HTTP header; to do so you +# can use: +# +# print \$IN->header(); +# + +}~; + } + } + return $code; +} + +sub _create_wizard { +# ------------------------------------------------------------------- +# Creates the Wizard.pm file which is used to load wizard information. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $author = $self->{plugin}->{meta}->{author} || ''; + my $version = $self->{plugin}->{meta}->{version} || ''; + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta}); + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$WIZARD/; + +END_OF_PLUGIN + $output .= GT::Dumper->dump(var => '$WIZARD', data => $self->{plugin}); + $output .= "\n\n1;\n"; + return $output; +} + +sub _load_tar { +# ------------------------------------------------------------------- +# Loads a tar file. +# + my $self = shift; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $self->{plugin}->{name} . ".tar"; + if (-e $file) { + $self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } + else { + $self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } +} + +sub _load_plugin { +# ------------------------------------------------------------------- +# Loads the meta information into self. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm') + or return $self->error('CANTLOAD', 'WARN', $self->{plugin}->{name}, "No Wizard.pm file found in tar!"); + +# Eval the install file. + my $file = $wizard->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $file, "Wizard.pm does not compile: $@"); + } + } + +# Load the information. + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + my $var = $plugin_pkg . "::WIZARD"; + { + no strict 'refs'; + $self->{plugin} = $$var; + } + + return 1; +} + +sub _list_editable { +# ------------------------------------------------------------------- +# Returns a select list of plugins that can be edited by the wizard. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + my $count = 0; + my $select = ""; + return $count ? $select : ''; +} + +1; + diff --git a/site/glist/lib/GT/RDF.pm b/site/glist/lib/GT/RDF.pm new file mode 100644 index 0000000..43a6e39 --- /dev/null +++ b/site/glist/lib/GT/RDF.pm @@ -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).*?]*?>),$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; +} + diff --git a/site/glist/lib/GT/SQL.pm b/site/glist/lib/GT/SQL.pm new file mode 100644 index 0000000..b01b786 --- /dev/null +++ b/site/glist/lib/GT/SQL.pm @@ -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 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 0> or C 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 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 + + $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. 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. + +=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 name. + +=item PREFIX + +This specifies a prefix to use for table names. See the L +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 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 is the name of the table you wish to create. See +L 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 is the name of the table you wish the modify. See +L 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 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 to the beginning of every +table name. This means anywhere you access the table C, the actual table +stored on the SQL server will be C. Note that the prefix should B +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 + +L + +L + +L + +L + +L + +=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 diff --git a/site/glist/lib/GT/SQL/Admin.pm b/site/glist/lib/GT/SQL/Admin.pm new file mode 100644 index 0000000..2d7b9c5 --- /dev/null +++ b/site/glist/lib/GT/SQL/Admin.pm @@ -0,0 +1,3042 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Admin +# Author : Scott Beck +# CVS Info : +# $Id: Admin.pm,v 1.146 2005/03/15 00:35:29 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Used to create a basic admin area for the most common admin +# setup. For anything more complex use the Display modules +# individually. This also proves an excelent example of +# how to use the HTML module. +# + +package GT::SQL::Admin; +# =================================================================== +use strict; +use GT::Base; +use GT::AutoLoader; +use GT::CGI; +use GT::SQL; +use GT::SQL::Display::HTML; + +use vars qw/ + @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS + $BAR_COLOR $BAR_FONT $TITLE_FONT $FONT $BODY + $ROW_COLOR1 $ROW_COLOR2 %ACTION +/; + +# Possible arguments to new +$ATTRIBS = { + header => undef, + footer => undef, + start_form => undef, + end_form => undef, + start_html => undef, + end_html => undef, + record => undef +}; + +# Error messages are stored in GT::SQL. +@ISA = qw/GT::Base/; +$ERROR_MESSAGE = 'GT::SQL'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.146 $ =~ /(\d+)\.(\d+)/; + +# Some default HTML attributes. +$BODY = 'bgcolor="#FFFFFF"'; +$BAR_COLOR = 'navy'; +$BAR_FONT = "face='Arial' size='2' color='#FFFFFF'"; +$TITLE_FONT = "face='Arial' size='2' color='#000000'"; +$FONT = "face='Tahoma,Arial,Helvetica' size='2' color='#000000'"; +$ROW_COLOR1 = 'bgcolor="#dddddd"'; +$ROW_COLOR2 = 'bgcolor="#eeeeee"'; + +%ACTION = ( + add_form => 1, + add_record => 1, + add_success => 1, + delete_records => 1, + delete_results => 1, + delete_search_form => 1, + delete_search_results => 1, + download_file => 1, + edit_table_def => 1, + editor_add_field => 1, + editor_add_field_form => 1, + editor_column_checks => 1, + editor_column_form => 1, + editor_column_help => 1, + editor_columns => 1, + editor_delete_field => 1, + editor_delete_field_form => 1, + editor_export_data => 1, + editor_export_data_form => 1, + editor_import_data => 1, + editor_import_data_form => 1, + editor_modify_columns => 1, + editor_table_form => 1, + editor_update_def => 1, + modify_error => 1, + modify_form => 1, + modify_multi_records => 1, + modify_multi_results => 1, + modify_multi_search_results => 1, + modify_record => 1, + modify_search_form => 1, + modify_search_results => 1, + modify_success => 1, + search_form => 1, + search_results => 1, + view_file => 1 +); + +# ================================================================================ # +# SIMPLE INTERFACE # +# ================================================================================ # + +## +# $obj->process ($defs, $in); +# -------------------- +# $defs must be the full path to the directory +# the definition file GT::SQL created. +# $in is a cgi object. This will process +# the cgi object from the forms it created. +# The proper changes will then be made and the +# results shown to the user. +# You should call this after testing to see if +# the input from the cgi is for_me. +## +sub process { + my $self = shift; + $self->initialize(@_) or return; + +# Find out what we are doing. + my $action = $self->{cgi}->{do}; + if (exists $ACTION{$action}) { + $self->$action(); +# print "

        QUERY STACK: ", GT::SQL->query_stack_disp, "
        "; # if ($self->{_debug}); + } + else { +# ERROR they should have called for_me to see if there was an action for me :) + return $self->error('NOACTION', 'FATAL', $action); + } +} + +sub initialize { + my ($self, @in) = @_; + +# Find out what we have, and store the CGI values in self->{cgi}. + my $opt = $self->common_param (@in) or return $self->error ("BADARGS", 'FATAL', '$obj->process ($in) where $in is a CGI object'); + $self->{in} = $opt->{cgi}; + $self->{cgi} = $self->common_param ($opt->{cgi}) or return $self->error ("BADARGS", 'FATAL', "You must pass in a cgi object"); + + my $tbl_names = ($self->{cgi}->{db}) || ($opt->{tables}) || (return $self->error ('BADARGS', 'FATAL', 'No table passed in via CGI or tables method')); + ref($tbl_names) || ($tbl_names = [ $tbl_names ]); + + if ($opt->{def_path}) { + return $self->error(BADARGS => FATAL => "The 'def_path' argument to \$admin->process is deprecated. You should pass in a GT::SQL object using 'db' instead."); + } + $self->{db} = $opt->{db} or return $self->error ('BADARGS', 'FATAL', 'Error: You must pass in a GT::SQL object.'); + $self->{table} = $self->{db}->table(@$tbl_names) or return; + +# Get the name of this table. + my $prefix = $self->{db}->prefix; + if (length $prefix) { + $self->{record} ||= join (',', map { s/^$prefix//; $_; } $self->{table}->name); + } + else { + $self->{record} ||= join (',', $self->{table}->name); + } + +# Get the Display object. + if ($opt->{display}) { + $self->{html} = $opt->{display}; + } + else { + $self->{html} = $self->{db}->html($self->{table}, $self->{cgi}); + } + $self->{html}->{url} = GT::CGI->url(remove_empty => 1); + +# Set any attributes the user passed in to process. + foreach my $option (keys %{$ATTRIBS}) { + $self->{$option} = $opt->{$option} if (exists $opt->{$option}); + } + return 1; +} + +sub preserve { + my $self = shift; + if (@_) { + my $preserve = shift; + $self->{preserve} = $preserve; + } + return $self->{preserve}; +} + +## +# GT::SQL::Admin->for_me ($in); +# ---------------------------- +# $in is a cgi object. You should call this in +# an if to see if the cgi object is from a form +# this module produced. +## +sub for_me { + my ($self, @in) = @_; + +# Get options + my $opt = $self->common_param (@in) or return $self->error ("BADARGS", 'FATAL', 'GT::SQL::Admin->for_me ($in) where $in is a CGI object'); + +# There is no action so return false + $opt->{do} or return 0; + $opt->{db} or return 0; + +# Check to see if there is a routine in this module. + return exists $ACTION{$opt->{do}}; +} + +# Make sure AUTOLOAD does not catch destroyed objects. +sub DESTROY {} + +# ================================================================================ # +# FILE HANDLING # +# ================================================================================ # + +$COMPILE{download_file} = __LINE__ . <<'END_OF_SUB'; +sub download_file { + my ($self, $msg) = @_; + my $in = $self->{in}; + + my $table_name = $in->param('db'); + my $id = $in->param('id'); + my $cn = $in->param('cn'); + my $src = $in->param('src') || 'db'; + my $fname = $in->param('fname'); + + if ( not ( $table_name and $id and $cn ) ) { + print $in->header(); + print $self->_start_html( { title => 'Error Downloading' } ); + print $self->_header ( "Unknown Document Refence", $@ ); + print $self->_end_html; + + return; + } + + require GT::SQL::File; + my $tbl = $self->{table}; + my ( $fh, $size ); + if ( $src eq 'db' ) { + eval { $fh = $tbl->file_info( $cn, $id ); }; + if ($fh) { + $fname = $fh->File_Name(); + $size = $fh->File_Size(); + } + } else { + require GT::SQL::File; + require GT::MIMETypes; + eval { $fh = GT::SQL::File->open($fname) }; + $size = -s $fname; + $fname = GT::SQL::File->get_filename($fname); + } + + if (!$fh) { + print $in->header(); + print $self->_start_html( { title => 'Error Downloading' } ); + print $self->_header ( "Error Downloading File", $@ || "Cannot file file pointed to by ID: $id and Column: $cn"); + print $self->_end_html; + } + + else { + print $self->{in}->header( + '-type' => 'application/download', + '-Content-Length' => $size, + '-Content-Transfer-Encoding' => 'binary', + '-Content-Disposition' => \"attachment; filename=$fname" + ); + + $fh->File_Binary() and binmode STDOUT; + + while (read ($fh, my $buffer, 4096)) { + print $buffer; + } + } +} +END_OF_SUB + + +$COMPILE{view_file} = __LINE__ . <<'END_OF_SUB'; +sub view_file { + my ($self, $msg) = @_; + my $in = $self->{in}; + + my $table_name = $in->param('db'); + my $id = $in->param('id'); + my $cn = $in->param('cn'); + my $src = $in->param('src') || 'db'; + my $fname = $in->param('fname'); + + if ( not ( $table_name and $id and $cn ) ) { + print $in->header(); + print $self->_start_html( { title => 'Error Downloading' } ); + print qq~Unknown document reference~; + print $self->_end_html; + return; + } + + my $tbl = $self->{table}; + my ( $fh, $mimetype, $size ); + if ( $src eq 'db' ) { + eval { $fh = $tbl->file_info( $cn, $id ); }; + if ( $fh ) { + $fname = $fh->File_Name(); + $mimetype = $fh->File_MimeType(); + $size = $fh->File_Size(); + } + } else { + require GT::SQL::File; + require GT::MIMETypes; + eval { $fh = GT::SQL::File->open($fname) }; + $size = -s $fname; + $mimetype = GT::MIMETypes->guess_type($fname); + $fname = GT::SQL::File->get_filename($fname); + } + + if (!$fh) { + print $in->header(); + print $self->_start_html( { title => 'Error Viewing' } ); + print $self->_header ( "Error Viewing File", $@ || "Cannot file file pointed to by ID: $id and Column: $cn"); + print $self->_end_html; + } + + else { + print $self->{in}->header( + '-type' => $mimetype, + '-Content-Length' => $size, + '-Content-Disposition' => \"inline; filename=$fname" + ); + + $fh->File_Binary() and binmode STDOUT; + + while (read ($fh, my $buffer, 4096)) { + print $buffer; + } + } + +} +END_OF_SUB + + +# ================================================================================ # +# SEARCHING RECORDS # +# ================================================================================ # + +$COMPILE{search_form} = __LINE__ . <<'END_OF_SUB'; +sub search_form { + my ($self, $msg) = @_; + $msg &&= qq|$msg|; + + print $self->{in}->header; + print $self->_start_html ( { title => "Search Form" }); + print $self->_header ("Search Form", $msg || "Search the database to view records."); + print $self->_start_form ( { do => "search_results", db => $self->{cgi}->{db}, method => 'POST' } ); + print $self->{html}->form ( { mode => 'search_form', search_opts => 1, file_browse => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons ("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->search_results; +# --------------------- +# Produces the search results for the user to view. +## +$COMPILE{search_results} = __LINE__ . <<'END_OF_SUB'; +sub search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->search_form ("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}); + my $hits = $self->{table}->hits(); + if ($hits == 0) { + return $self->search_form ("Your search did not match any records."); + } + + print $self->_start_html ( { title => "Search Results" }); + print $self->_header ("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + my $name = GT::CGI->url(remove_empty => 1); + if ($hits > ($self->{cgi}->{mh} || 25)) { + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar( $self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + + if ( $self->{in}->param('dr') and $self->{in}->param('dr') eq 'rows' ) { + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + my $i = 0; + while (my $result = $sth->fetchrow_hashref) { + print "", $self->{html}->display_row ( { mode => 'search_results', values => $result }), ""; + } + print "
        "; + } + + else { + while (my $result = $sth->fetchrow_hashref) { + print "

        ", $self->{html}->display ( { mode => 'search_results', values => $result }); + } + } + + print $speedbar if ($speedbar); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# ADD RECORDS # +# ================================================================================ # + +## +# $obj->add_form; +# --------------- +# This will print the add form for the current +# tables that we are working with. All the +# options that were set in settings will apply +# to the html that is printed here. +## +$COMPILE{add_form} = __LINE__ . <<'END_OF_SUB'; +sub add_form { + my ($self, $msg) = @_; + print $self->{in}->header; + my $hk = [$self->{table}->ai]; + $msg &&= qq|$msg|; + print $self->_start_html ( { title => $msg ? "Add Record Failed" : "Add Record" }); + print $self->_header ($msg ? "Add Record Failed" : "Add Record", $msg || "Add a record to the database"); + print $self->_start_form ( { do => "add_record", db => $self->{cgi}->{db} } ); + print $self->{html}->form( { mode => 'add_form', defaults => 1, hide => $hk, hide_timestamp => 1, search_opts => 0, file_field => 1 }); + print "

        ", $self->_buttons ("Add"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + + return 1; +} +END_OF_SUB + +## +# $obj->add_record; +# ----------------------- +# This will add the record to the database and +# return the record ID on success undef on failure. +## +$COMPILE{add_record} = __LINE__ . <<'END_OF_SUB'; +sub add_record { + my $self = shift; + +# Turn arrays into delimited fields + $self->format_insert_cgi; + + if (defined(my $ret = $self->{table}->add($self->{cgi}))) { + $self->add_success ($ret); + } + else { + local $^W; + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + + $self->add_form ("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->add_success; +# ------------------ +# This will print the success page after adding a +# record. +## +$COMPILE{add_success} = __LINE__ . <<'END_OF_SUB'; +sub add_success { + my ($self, $id) = @_; + print $self->{in}->header; + + my $hsh; + if ($self->{table}->ai) { + $hsh = $self->{table}->get ($id, 'HASH'); + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{$_}; } + $hsh = $self->{table}->get ($lookup, 'HASH'); + } + + print $self->_start_html ( { title => "Record Added" }); + print $self->_header ("Record Added", "The following record was successfully added:"); + print "

        "; + print $self->{html}->display ( { mode => 'add_success', values => $hsh } ); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# DELETE RECORDS # +# ================================================================================ # + +## +# $obj->delete_search_form; +# ------------------------- +# Produces the search form to search to delete records. +# +# $obj->delete_search_form ($message); +# ------------------------------------ +# Same thing as above but puts the message at the top in +# red and bold. Great for errors or not search results. +## +$COMPILE{delete_search_form} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html ( { title => "Delete Records" }); + print $self->_header ("Delete Records", $msg || "Search to delete records."); + print $self->_start_form ( { do => "delete_search_results", db => $self->{cgi}->{db}, method => 'POST' } ); + print $self->{html}->form( { mode => 'delete_search_form', search_opts => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons ("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_search_results; +# ---------------------------- +# Performs the search and returns the result forms +# to delete records. +## +$COMPILE{delete_search_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->delete_search_form ("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth ($self->{cgi}); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->delete_search_form ("Your search returned no results."); + } + + print $self->_start_html ( { title => "Search Results" }); + print $self->_start_form ( { do => 'delete_records', db => $self->{cgi}->{db} }); + print $self->_header ("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + + my @pk; + +# If we have a relation + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ( $self->{in}->param('dr') eq 'rows' ) { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can ('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name ($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row ( { mode => 'search_results', values => $result }), ""; + print qq~~; + $i++; + } + + print "
        Delete
        \n"; + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display ( { mode => 'delete_search_results', values => $result } ); + print "
        \n"; + $i++; + } + + } + + + print $speedbar if ($speedbar); + print < 2; # Only print the Check All box if there is more than one thing to check + +

        Check All

        +END_OF_HTML + print "

        ", $self->_buttons ("Delete"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_records; +# --------------------- +# Performs the delete and returns the success page. +## +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { + my $self = shift; + +# Make sure we have something to delete. + $self->{cgi}->{delete} or return $self->delete_results(0); + +# If they selected only one record to delete we still need an array ref + ref $self->{cgi}->{delete} eq 'ARRAY' or $self->{cgi}->{delete} = [$self->{cgi}->{delete}]; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{delete}}) { + my $change = {}; + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + next unless (keys %$change); + my $ret = $self->{table}->delete($change); + if (defined $ret and ($ret != 0)) { + $rec_modified++; + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return $self->delete_results ($rec_modified); +} +END_OF_SUB + +$COMPILE{delete_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_results { + my ($self, $num_modified) = @_; + print $self->{in}->header; + + print $self->_start_html ( { title => "Records Deleted" }); + print $self->_header ("Records Deleted", "$num_modified record(s) were deleted."); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY RECORDS # +# ================================================================================ # + +## +# $obj->modify_search_form; +# ------------------------- +# Returns the html form to search to modify a +# record. +# +# $obj->modify_search_form ($message); +# ---------------------------------- +# The same thing just puts the message at the top of the +# field. Great for errors. +## +$COMPILE{modify_search_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html ( { title => "Modify Record" }); + print $self->_header ("Modify Record", $msg || "Search to modify a record."); + print $self->_start_form ( { do => "modify_search_results", db => $self->{cgi}->{db}, method => 'POST' } ); + print $self->{html}->form( { mode => 'modify_search_form', search_opts => 1 }); + print "

        ", $self->_search_options ( { modify_mult => 1 } ); + print "

        ", $self->_buttons ("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_search_results; +# ---------------------------- +# Returns the form that displays the results of a +# search to modify a record. +## +$COMPILE{modify_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_results { + my $self = shift; + print $self->{in}->header; + +# If they are modifying multiple records. + if ($self->{cgi}->{modify_multi_form}) { + return $self->modify_multi_search_results (@_); + } + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form ("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form ($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form ("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html ( { title => "Search Results" }); + print $self->_start_form ( { do => 'modify_form', db => $self->{cgi}->{db} }); + print $self->_header ("Search Results", "Your search returned $hits result(s)."); + + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ( $self->{in}->param('dr') eq 'rows' ) { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row ( { mode => 'modify_search_results', values => $result } ); + print "\n"; + $i++; + } + + print "
        Modify
        \n"; + + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display ( { mode => 'modify_search_results', values => $result } ); + print "
        \n"; + $i++; + } + + }; + + + print $speedbar if ($speedbar); + print "

        ", $self->_buttons ("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_form ($message); +# ------------------ +# Returns the form to modify a single record. +# $message is optional. It will be at the top of the form. +## +$COMPILE{modify_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + my $values; + my $mod = $self->{cgi}->{modify}; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error ("Please select a record to modify before continuing."); + } + if ($self->{cgi}->{modify} == 0) { + $values = $self->{cgi}; + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{"$mod-$_"}; } + $values = $self->{table}->get ($lookup, 'HASH'); + } + print $self->_start_html ( { title => "Modify Record" }); + print $self->_header ("Modify Record", $msg || "Modify a record."); + print $self->_start_form ( { do => "modify_record", db => $self->{cgi}->{db} } ); + print $self->{html}->form( { mode => 'modify_form', values => $values, view_key => 1, file_field => 1, file_delete => 1 }); + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + print qq( +

        +
        + + ); + print $self->_start_form ( { do => "delete_records", db => $self->{cgi}->{db} }, { name => 'admin_delete' } ); + print qq(
        ); + for (@pk) { + print qq(); + } + print qq( + + + ); + print qq( +
        +
        + ); + print $self->_end_form; + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_record; +# -------------------- +# Makes the modifications to the record. Returns the +# failure page on error (which is the modify form with a message) +# and the success page on success. +## +$COMPILE{modify_record} = __LINE__ . <<'END_OF_SUB'; +sub modify_record { + my $self = shift; + +# Format arrays for insertion + $self->format_insert_cgi; + + if ($self->{table}->modify ($self->{cgi})) { + return $self->modify_success; + } + else { + $self->{cgi}->{modify} = 0; + if ($GT::SQL::errcode eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{$_}; + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if ($rec) { + foreach (keys %$rec) { + $self->{cgi}->{$_} = $rec->{$_}; + } + return $self->modify_form ("The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit."); + } + else { + return $self->modify_error ("The record you attempted to modify could not be found."); + } + } + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + return $self->modify_form ("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->modify_success; +# --------------------- +# Returns the success form after someone modifies +# a record. +## +$COMPILE{modify_success} = __LINE__ . <<'END_OF_SUB'; +sub modify_success { + my $self = shift; + print $self->{in}->header; + my $lookup = {}; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + foreach (@pk) { + $lookup->{$_} = $self->{cgi}->{$_} if (exists $self->{cgi}->{$_}); + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if (! $rec) { + return $self->modify_error ("The record you attempted to modify could not be found."); + } + + print $self->_start_html ( { title => "Record Modified" }); + print $self->_header ("Record Modified", "The following record was successfully updated:"); + print "

        "; + + print $self->{html}->display ( { mode => 'modify_success', values => $rec } ); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_error; +# --------------------- +# Modify error which doesn't/can't display the record. +## +$COMPILE{modify_error} = __LINE__ . <<'END_OF_SUB'; +sub modify_error { + my $self = shift; + my $msg = shift; + print $self->{in}->header; + + print $self->_start_html ( { title => "Modify Error" }); + print $self->_header ("Modify Error", $msg); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY MULTIPLE RECORDS # +# ================================================================================ # + +## +# $obj->modify_multi_search_results; +# ------------------------ +# Returns the forms to modify records. +## +$COMPILE{modify_multi_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_search_results { + + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form ("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form ($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form ("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html ( { title => "Modify Search Results" }); + print $self->_start_form ( { do => 'modify_multi_records', db => $self->{cgi}->{db} }); + print $self->_header ("Modify Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + while (my $result = $sth->fetchrow_hashref) { + print qq~

        ~; + print $self->{html}->form ( { mode => 'modify_multi_search_results', values => $result, multiple => $i, view_key => 1, file_field => 1, file_delete => 1 } ); + print "
        \n"; + $i++; + } + print $speedbar if ($speedbar); + print "

        ", $self->_buttons ("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_multi_records; +# --------------------------- +# This performs the modify on the multiple records. This returns +# the success page on error and the modify form on failure. It should +# call the modify form in a way that it can reproduce the records that +# were not successfully modified. See the comments above to see how +# modify_multi_form is called. +## +$COMPILE{modify_multi_records} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_records { + my $self = shift; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error ("Please select a record to modify before continuing."); + } +# If they selected only one record to modify we still need an array ref + ref $self->{cgi}->{modify} eq 'ARRAY' or $self->{cgi}->{modify} = [$self->{cgi}->{modify}]; + +# Format the cgi for inserting + $self->format_insert_cgi; + +# Hash to handle errors if there are any errors. + my $errors = {}; + my $errcode = {}; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{modify}}) { + +# The hash ref, we need, to modify a record. + my $change = {}; + +# For through the column names to build our modification hash + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + +# Make the changes and capture any errors. + my $ret = $self->{table}->modify($change); + if (defined ($ret)) { + $rec_modified++; + } + else { + if ($GT::SQL::error){ + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + $errors->{$rec_num} = "
      • $error"; + } + $errcode->{$rec_num} = $GT::SQL::errcode if ($GT::SQL::errcode); + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return (keys %{$errors}) ? $self->modify_multi_results ($rec_modified, $errors, $errcode) : $self->modify_multi_results ($rec_modified); +} +END_OF_SUB + +## +# $obj->modify_multi_results ($num_modified); +# ------------------------------------------- +# This will return the results page after the user modifies +# the record from the modify_multi_form. $num_modified is the +# number of records that were modified. +# +# $obj->modify_multi_results ($num_modified, \%not_modified, \%error_codes); +# ----------------------------------------------------------- +# This is how you handle errors. The first argument is the number +# of records that were modified. The second is a hash ref of primary +# keys to reasons the message was not modified. If there is more than +# one column that makes up the primary key they should be flatened +# to a comma separated list of keys in the proper order. +## +$COMPILE{modify_multi_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_results { + my ($self, $num_modified, $errors, $errcodes) = @_; + my ($ok_out, $error_out) = ('', ''); + $errcodes ||= {}; + +# Lets get our error records if we messed up. + if ($errors) { + my @cond = (); + $error_out = $self->_header ("Modify Failed", "The following record(s) were not modified successfully. Please correct the errors and submit again."); + $error_out .= $self->_start_form ( { do => 'modify_multi_records', db => $self->{cgi}->{db} }); + + my $cols = $self->{table}->cols; + foreach my $rec (keys %$errors) { + my $values = {}; + if ($errcodes->{$rec} eq 'NORECMOD') { + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= qq~

        The record could not be found in the database~; + $error_out .= qq~
           ~; + $error_out .= $self->{html}->display ( { mode => 'modify_multi_results_norec', values => $values } ); + $error_out .= qq~
        \n~; + } + elsif ($errcodes->{$rec} eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{"$rec-$_"}; + } + my $result = $self->{table}->get($lookup, 'HASH'); + foreach (keys %$result) { + $values->{$_} = $result->{$_}; + } + $error_out .= qq~

        The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit.~; + $error_out .= qq~
        ~; + $error_out .= $self->{html}->form ( { mode => 'modify_multi_result_changed', values => $values, multiple => $rec } ); + $error_out .= qq~
        \n~; + } + else { + $error_out .= qq~

        $errors->{$rec}
        ~; + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= $self->{html}->form ( { values => $values, multiple => $rec, mode => 'modify_multi_results_err' } ); + $error_out .= qq~
        \n~; + } + } + $error_out .= "

        " . $self->_buttons ("Modify"); + $error_out .= $self->_end_form; + } + +# If there were successfull modifications. + if ($num_modified) { + $ok_out = $self->_header ("Modify Success", "$num_modified record(s) were successfully updated."); + $ok_out .= "

        "; + } + +# Print the HTML + print $self->{in}->header; + print $self->_start_html ( { title => "Record Modified" }); + print $ok_out; + print $error_out; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{format_insert_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_insert_cgi { + my $self = shift; + my $cols = $self->{table}->cols; + foreach (keys % $cols) { + if (! exists $self->{cgi}->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX') { + $self->{cgi}->{$_} = ''; + } + next unless (ref ($self->{cgi}->{$_}) eq 'ARRAY'); + $self->{cgi}->{$_} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort (@{$self->{cgi}->{$_}})); + } +} +END_OF_SUB + +$COMPILE{format_search_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_search_cgi { + my $self = shift; + foreach (keys %{$self->{table}->cols}) { + next unless (ref ($self->{cgi}->{$_}) eq 'ARRAY'); + if (exists ($self->{cgi}->{"$_-opt"}) and $self->{cgi}->{"$_-opt"} eq 'LIKE') { + $self->{cgi}->{$_} = join ("$GT::SQL::Display::HTML::INPUT_SEPARATOR%", sort (@{$self->{cgi}->{$_}})); + } + else { + $self->{cgi}->{$_} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort (@{$self->{cgi}->{$_}})); + } + } +} +END_OF_SUB + +# ================================================================================ # +# EDIT TABLES # +# ================================================================================ # + +$COMPILE{editor_table_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_table_form { +# ------------------------------------------------------------------- +# $obj->editor_table_form; +# ------------------------ +# Prints the form to edit the table +# definitions. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + +# Update the table if required + $self->{in}->param('update_def') and $msg .= $self->edit_table_def || "Table Definition Update Successful"; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html ( { title => "Table Editor: $table" }); + print $self->_header ("Table Editor", $msg || "Table Maintenace: $table"); + print $self->_start_form ( { do => 'editor_table_form', db => $self->{cgi}->{db}, update_def => 1 }); + my $url = GT::CGI->url ({ query_string => 0 }); + + my $show_weight_h = (keys %{$self->{table}->weight}) ? "Index Weight" : ''; + if ($show_weight_h) { + $show_weight_h = qq~Search
        Weight
        ~; + } + else { + $show_weight_h = ''; + } + print qq~ +

        Edit $table Table Definition
        + Below is all the columns in your $table table. By clicking on one of the column names, you can view more details + as well as alter the column definition.

        +
        + + + + + + + + + + + $show_weight_h + + ~; + my %cols = %{$self->{table}->cols}; + foreach my $column ($self->{table}->ordered_columns) { + my %attribs = %{$cols{$column}}; + $attribs{pos} ||= ' '; + $attribs{type} ||= ' '; + $attribs{not_null} ||= ' '; + $attribs{default} = ' ' if not defined $attribs{default} or $attribs{default} eq ''; + $attribs{form_display} ||= ' '; + $attribs{form_type} ||= 'TEXT'; + $attribs{regex} ||= ' '; + + if ($show_weight_h) { + $attribs{weight} ||= ' '; + $show_weight_h = qq~~; + } + ($attribs{not_null} eq '1') ? ($attribs{not_null} = "Yes") : ($attribs{not_null} = "No"); + print qq~ + + + ~; + if ($attribs{protect}) { + print qq~~; + } + else { + print qq~~; + } + print qq~ + + + + + + + $show_weight_h + + ~; + } + print qq~ +
        PositionColumn
        Name
        Column
        Type
        Not
        Null
        DefaultForm
        Display
        Form
        Type
        Form
        Regex
        $attribs{weight}
        $attribs{pos}$column$column$attribs{type}~; + print "($attribs{size})" if ($attribs{size}); + print "(" . join (", " => @{$attribs{values}}) . ")" if ($attribs{values} and (ref $attribs{values})); + print qq~$attribs{not_null}$attribs{default}$attribs{form_display}$attribs{form_type}$attribs{regex}
        +
        + +
        + +
        + + + + + + + +
        Database Information
        Indexing Scheme + +
        +
        + +
        + +
        + + +
        +
        +
        + +
        + ~; + + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{edit_table_def} = __LINE__ . <<'END_OF_SUB'; +sub edit_table_def { +# ------------------------------------------------------------------- + my $self = shift; + my $in = $self->{in}; + +# handle the indexing scheme + my $e = $self->{db}->editor( $in->param('db') ); + $e->change_search_driver( $in->param('search_driver') ) or return $GT::SQL::error; + + return; +} +END_OF_SUB + +$COMPILE{editor_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_columns { +# ------------------------------------------------------------------- +# Form to modify a selected column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + my $column = $self->{cgi}->{modify}; + my %cols = $self->{table}->cols; + my %attribs = %{$cols{$column}}; + my $url = GT::CGI->url ({ query_string => 0 }); + exists $cols{$column} or return $self->editor_table_form ("Column ($column) does not exist in table" . $self->{table}->name); + +# Print the intro. + print $self->_start_html ( { title => "Edit $column Column Definition" }); + print $self->_header ("Table Editor", $msg || "Edit $column Column Definition"); + print $self->_start_form ( { do => 'editor_modify_columns', db => $self->{cgi}->{db}, modify => $column }); + print qq~ +

        For information on what each column means, click here.

        + ~; + +# Set up defaults for the fields + foreach my $col (qw/column type not_null file_save_in file_save_url file_max_size file_save_scheme default form_display form_type form_size form_names form_values regex weight values size/) { + $attribs{$col} = $self->{cgi}->{$col} if (defined $self->{cgi}->{$col}); + } + $attribs{column} ||= $column; + $attribs{form_type} ||= 'TEXT'; + $attribs{form_size} ||= ($attribs{form_type} eq 'SELECT') ? 0 : ''; + ref $attribs{form_size} and ($attribs{form_size} = join (",", @{$attribs{form_size}})); + ref $attribs{form_names} and ($attribs{form_names} = join ("\n", @{$attribs{form_names}})); + ref $attribs{form_values} and ($attribs{form_values} = join ("\n", @{$attribs{form_values}})); + ref $attribs{values} and ($attribs{values} = join ("\n", @{$attribs{values}})); + +# Display the form. + my $index_list = $self->_index_list($column); + print $self->editor_column_form (\%attribs, $index_list, 'modify'); + + print $self->_buttons ("Update Table"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{editor_modify_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_modify_columns { +# -------------------------------------------------------- +# Modifies a column definition. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $column = $self->{cgi}->{modify} || return $self->editor_columns ("You must enter a column name."); + foreach my $def (qw/column type not_null default form_display form_type form_size file_save_in file_save_url file_max_size file_save_scheme regex weight size/) { + $attribs{$def} = $self->{cgi}->{$def} if (defined $self->{cgi}->{$def}); + } + $attribs{form_type} ||= 'TEXT'; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + +# Keep any values that where there before + my $old_def = $self->{table}->cols->{$column}; + for my $val (keys %$old_def) { + $attribs{$val} = $old_def->{$val} unless exists $attribs{$val}; + } + +# Error checking + my $errors = $self->editor_column_checks ($column, \%attribs, 'modify'); + if ($self->{cgi}->{index} eq 'primary' and ($column ne $self->{table}->{schema}->{pk})) { + $errors .= "

      • This table already has a primary key."; + } + $errors and return $self->editor_columns ("
          $errors
        "); + +# Add/Drop indexes. + my $index_type = $self->_index_type($column); + my @post_change; + if ($index_type ne $self->{cgi}->{index}) { + if ($index_type eq 'none') { + # Adding an index - delay this until _after_ the column has been changed + if ($self->{cgi}->{index} eq 'regular') { + push @post_change, [add_index => "${column}_idx" => [$column]]; + } + else { + push @post_change, [add_unique => "${column}_idx" => [$column]]; + } + } + elsif ($self->{cgi}->{index} eq 'none') { + # Dropping an index + if ($index_type eq 'regular') { + my $index = $self->{table}->index; + INDEX: foreach my $index_name (keys %$index) { + foreach my $col_name (@{$index->{$index_name}}) { + next unless ($col_name eq $column); + $editor->drop_index ($index_name) or return $self->editor_columns ($GT::SQL::error); + last INDEX; + } + } + } + else { + my $unique = $self->{table}->unique; + INDEX: foreach my $unique_name (keys %$unique) { + foreach my $col_name (@{$unique->{$unique_name}}) { + next unless ($col_name eq $column); + $editor->drop_unique ($unique_name) or return $self->editor_columns ($GT::SQL::error); + last INDEX; + } + } + } + } + } + +# Make the changes + delete $attribs{column}; + $editor->alter_col ($column, \%attribs) or return $self->editor_columns ($editor->error); + + for (@post_change) { + my ($meth, @args) = @$_; + $editor->$meth(@args); + } + + return $self->editor_table_form ("$column has been updated!"); +} +END_OF_SUB + +$COMPILE{editor_column_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_form { +# ------------------------------------------------------------------- +# Displays an Add/Modify column form. +# + my ($self, $attribs, $index_list, $mode) = @_; + + my $output = qq~ +
        + ~; + + if ($mode eq 'add') { + $output .= qq~ + + + ~; + } + + else { + $output .= qq~ + + + + ~; + }; + + my $match = 0; + foreach (qw/INT CHAR TEXT DATE ENUM/) { + if ($attribs->{type} eq $_) { + $match = 1; + last; + } + } + my $extra = ''; + if (! $match) { + $extra = " + + + + + + + + + + + + + + + + + + ~; + +# Only display Search Weight form if this table has a search weight set. + my %weights = $self->{table}->weight; + my $show_weight = 0; + foreach (keys %weights) { + $weights{$_} and $show_weight++; + } + if ($show_weight) { + $output .= qq~~; + } + + $output .= qq~ +
        Database Information
        Column Name
        Database Information
        WARNING: If you change a field's type, data in that field may be lost. Also, if you alter one of the system fields, it may render your system inoperable.
        Column Name$attribs->{column}
        Column Type +
        Column Index$index_list
        Column Size
        (Only for CHAR types)
        Column Values
        (Only for ENUM types)
        Not Null + + Yes{not_null}); $output .= qq~> + No{not_null}); $output .= qq~> +
        Default
        Form Information
        Form Display
        Form Type +
        Form Size
        Form Names
        (Stored in Database)
        Only for checkbox, multi-select or radio forms.
        Form Values
        (Displayed on Form)
        Only for checkbox, multi-select or radio forms.
        File Save Location
        (Only for FILE types. Stored on disk)
        File Save URL
        (Only for FILE types)
        File Save Method
        (Only for FILE types)
        +
        File Maximum Size
        (Only for FILE types.)
        Form Regex
        Search Weight
        +
        +
        + ~; + return $output; +} +END_OF_SUB + +$COMPILE{editor_column_checks} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_checks { +# ------------------------------------------------------------------- +# Check to make sure a column add/change is valid. +# + my ($self, $column, $attribs) = @_; + my $errors = ''; + +# Remove attributes that don't make sense. + $attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR' or delete $attribs->{size}; + $attribs->{type} eq 'ENUM' or delete $attribs->{values}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_names}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_values}; + $attribs->{form_type} =~ /^(?:CHECKBOX|RADIO)$/ and delete $attribs->{form_size}; + $attribs->{default} =~ /^\s*$/ and delete $attribs->{default}; + +# Go through and weed out problem cases. + if ($column !~ /^(\w+)$/) { + $errors .= "
      • Column name '$column' is invalid. The column name can only contain letters, numbers and an underscore."; + } + if ($column =~ /^[\d_]/) { + $errors .= "
      • Column name '$column' is invalid. Column names can not start with a number or an underscore."; + } + if (($attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR') and ($attribs->{size} > 255 or $attribs->{size} < 1)) { + $errors .= "
      • Size '$attribs->{size}' is invalid. It must be between 1 and 255."; + } + if ($attribs->{type} eq 'ENUM') { + unless (ref $attribs->{values} eq 'ARRAY' and @{$attribs->{values}} >= 1) { + $errors .= "
      • You must specify the ENUM values in the 'Column Value' text area. Enter the value one perl line.
      • \n"; + } + if ($attribs->{default}) { + my $ok; + for my $value (@{$attribs->{values}}) { + $ok = 1, last if $value eq $attribs->{default}; + } + unless ($ok) { + $errors .= "
      • Your default must match one of the listed ENUM values."; + } + } + } + if ($attribs->{type} =~ /INT$/) { + if ($attribs->{default} and $attribs->{default} =~ /\D/) { + $errors .= "
      • The default value for INT columns cannot contain non-integral values.
      • "; + } + } + if ($attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/) { + if (! (@{$attribs->{form_names}} or @{$attribs->{form_values}}) ) { + $errors .= "
      • For radio, checkbox and select forms, you must specify the names and the values in the two textarea boxes one per line. The names are what is stored in the database, and the values is what is displayed in the browser."; + } + else { + if (@{$attribs->{form_names}} ne @{$attribs->{form_values}}) { + $errors .= "
      • Make sure you have the same number of lines for Form Names as you do for Form Values."; + } + } + } + if ($attribs->{form_type} eq 'TEXTAREA') { + if ($attribs->{form_size} =~ /^\s*(\d+)\s*,\s*(\d+)\s*$/) { + $attribs->{form_size} = [$1, $2]; + } + elsif ($attribs->{form_size} =~ /^\s*(\d+)\s*$/) { + $attribs->{form_size} = $1; + } + else { + $errors .= "
      • For TEXTAREA forms, please specify the size of the textarea as COLS,ROWS. For example, to have a 50 column, by 6 rows textarea box, you would enter 50,6 in the Form Size box."; + } + } + if ($attribs->{form_type} eq 'FILE') { + if ( $attribs->{file_save_in} ) { + ( -e $attribs->{file_save_in} and -w $attribs->{file_save_in} ) or + $errors .= "
      • File Save Location does not exist or is not writeable."; + } + else { + $errors .= "
      • File Save Location must be set."; + } + if ( $attribs->{type} ne 'CHAR' ) { + $errors .= "
      • Database column must be of CHAR type"; + } + } + if (($attribs->{not_null} == 0) and ($self->{cgi}->{index} ne 'none')) { + $errors .= "
      • A column must be defined as not null if you want to index it."; + } + if (($self->{cgi}->{index} ne 'none') and ($attribs->{type} eq 'TEXT')) { + $errors .= "
      • You can not have an index on TEXT columns."; + } + if ($attribs->{weight} and $attribs->{weight} !~ /^\d+$/) { + $errors .= "
      • Search weight can only contain digits.
      • "; + } + return $errors; +} +END_OF_SUB + +$COMPILE{editor_add_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field_form { +# ------------------------------------------------------------------- +# Displays a form to add a new column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html ( { title => "Table Editor: $table" }); + +# Set up defaults for the fields + my %attribs = (); + foreach my $def (qw/ + column type not_null default form_display form_type form_size regex weight + size form_names form_values values file_save_in file_save_scheme + file_save_url file_max_size + /) { + $attribs{$def} = defined $self->{cgi}->{$def} ? $self->{cgi}->{$def} : ''; + } + $attribs{form_type} ||= 'TEXT'; + my $url = GT::CGI->url ({ query_string => 0 }); + + print $self->_header ("Table Editor", $msg || "Add a New Field to $table"); + print $self->_start_form ( { do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +

        For information on what each column means, click here.

        + ~; + my $index_list = $self->_index_list(); + print $self->editor_column_form (\%attribs, $index_list, 'add'); + + print $self->_buttons ("Add Field to"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_add_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field { +# ------------------------------------------------------------------- +# Add a new column to the database. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $table = $self->{cgi}->{db}; + my $column = $self->{cgi}->{column} || return $self->editor_add_field_form ("You must enter a column name."); + my %cols = $self->{table}->cols; + $attribs{type} = $self->{cgi}->{type} || return $self->editor_add_field_form ("You must enter a column type."); + $attribs{size} = $self->{cgi}->{size}; + $attribs{form_display} = $self->{cgi}->{form_display} || $self->{cgi}->{column}; + $attribs{not_null} = $self->{cgi}->{not_null} || 0; + $attribs{default} = $self->{cgi}->{default} || ''; + $attribs{form_type} = $self->{cgi}->{form_type} || 'TEXT'; + $attribs{form_size} = $self->{cgi}->{form_size} || ''; + $attribs{regex} = $self->{cgi}->{regex} || ''; + $attribs{weight} = $self->{cgi}->{weight} || ''; + $attribs{file_save_in} = $self->{cgi}->{file_save_in} || ''; + $attribs{file_save_url} = $self->{cgi}->{file_save_url} || ''; + $attribs{file_max_size} = $self->{cgi}->{file_max_size} || ''; + $attribs{file_save_scheme} = $self->{cgi}->{file_save_scheme} || ''; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + $attribs{pos} = keys (%cols) + 1; + +# Error checking + my $errors = $self->editor_column_checks ($column, \%attribs, 'add'); + if (exists $cols{$column}) { + $errors .= "

      • Column '$column' already exists, please choose another name."; + } + if ($self->{cgi}->{index} eq 'primary') { + $errors .= "
      • You can not add a primary key to an existing table."; + } + $errors and return $self->editor_add_field_form("
          $errors
        "); + +# Add the column. + delete $attribs{column}; + $editor->add_col($column, \%attribs) or return $self->editor_add_field_form("Unable to add column '$column': $GT::SQL::error"); + + my $field_form_message = "The column '$column' was added successfully, however an error occured while "; + $self->{cgi}->{modify} = $column; +# Add the indexes. + if ($self->{cgi}->{index} eq 'regular') { + $editor->add_index($column . '_idx' => [$column]) or return $self->editor_columns("$field_form_message adding the index: $GT::SQL::error"); + } + elsif ($self->{cgi}->{index} eq 'unique') { + $editor->add_unique($column . '_udx' => [$column]) or return $self->editor_columns("$field_form_message adding the unique index: $GT::SQL::error"); + } + $self->{table}->reload; + + return $self->editor_table_form("The database has been succesfully updated."); +} +END_OF_SUB + +$COMPILE{editor_delete_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field_form { +# ------------------------------------------------------------------- +# Displays a form to delete a column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html ( { title => "Table Editor: $table" }); + print $self->_header ("Table Editor", $msg || "Delete a Field from $table."); + print $self->_start_form ( { do => 'editor_delete_field', db => $self->{cgi}->{db} }); + + print qq~ +
        +
        +

        WARNING: If you remove a field, all data in that field will be lost. Also, if you remove + one of the system fields, certain functions may not work any more!

        ~; + my @cols = grep !exists $self->{table}->{schema}->{cols}->{$_}->{protect}, $self->{table}->ordered_columns; + if (@cols) { + print qq~ + Delete the following field: + +

        + ~; + } + else { + print qq<

        No columns can be deleted.

        >; + } + print qq~ +
        +
        +
        + ~; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_delete_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field { +# ------------------------------------------------------------------- +# Remove a field from the table. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my $table = $self->{cgi}->{db}; + my $field = $self->{cgi}->{'delete-field'} || return $self->editor_delete_field_form ("Please select a field to delete!"); + ($field eq 'ID') and return $self->editor_delete_field_form ("You can't remove the ID field."); + +# Drop the column from the database. + $editor->drop_col ($field) or return $self->editor_delete_field_form ($GT::SQL::error); + + return $self->editor_delete_field_form ("The database has been successfully updated."); +} +END_OF_SUB + +$COMPILE{editor_update_def} = __LINE__ . <<'END_OF_SUB'; +sub editor_update_def { +# ------------------------------------------------------------------- +# Re-sync the def file with what's in the database. +# + my $self = shift; + +# We need a creator for this. + my $c = $self->{db}->creator($self->{table}->name); + $c->load_table or return $self->editor_table_form ("Could not update def files reason $GT::SQL::error"); + +# Re Load our table object. + $self->{table}->reload; + + return $self->editor_table_form ("The .def file has been re-synced."); +} +END_OF_SUB + +$COMPILE{editor_column_help} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_help { +# -------------------------------------------------------- +# Displays a help page for the editor. +# + my ($self, $msg) = @_; + my $table = $self->{cgi}->{db}; + print $self->{in}->header; + print $self->_start_html; + print $self->_header ("Table Editor", $msg || "Add/Edit Columns Help."); + print $self->_start_form ( { do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +
        + +

        From here you can add a new column to your table $table. When creating your column, you should set the following options: +

          +
        • Column Name: This is the name of your column. It must be a valid SQL name, which is just letters, numbers and the underscore character. Also, + try to avoid reserved words like FROM, SELECT, WHERE, JOIN, etc. +
        • Column Type: This is the type of column you want to create. Your choices are: +
            +
          • INT: This stores integer numbers, i.e. 1, 2, 3. Whole numbers without decimal points. +
          • CHAR: This stores any string up to a maxium size of 255. If you set a CHAR, you must set the + maximum size in Column Size. +
          • TEXT: This stores a (virtually) unlimited amount of text. Use this for storing very large + amounts of texts. +
          • DATE: This stores a date defaulting to yyyy-mm-dd format. +
          • ENUM: This stores an enumerated list. This is useful when you want a field that can be + one of several values. For example, you could create a Status column that can contain + the values: 'Not Registered', 'Registered', 'Moderator', 'SuperUser'. The entries in this + column must be one of the listed values. You specify what values you want using one line + per entry in the Column Values field. +
          +
        • Column Index: This determins what sort of index the SQL server should use to speed up queries. If you use + an index, you must set Not Null to Yes. +
        • Column Size: This is only useful for CHAR types. It stores the maximum size a field can be and should range + anywhere from 1 to 255. +
        • Column Values: This is only useful for ENUM types. It stores the list of possible values, one per line. +
        • Not Null: If you set this to Yes, then a value must be entered for this column. If you set this to No, then + when you add a record, this column can be left blank. +
        • Default: This is the default value that will be displayed when adding a record. +
        • Form Type: This is the type of form to use when adding or modifying a record. Your choices are: +
            +
          • Hidden: This column will be hidden on the add and modify forms. +
          • Select: A select list will be generated. For select lists, Form Size determines the size + of the select list (set to 0 for a single select list, higher for multiple select lists). You should + enter the values of the select list (what will be displayed to the user) in the Form Values textarea, and + the data of the select list (what will be stored in the database) in the Form Names textarea. +
          • Checkbox: This generates a set of checkboxes. You need to enter into Form Values a list of all + the checkbox values (what will be displayed to the user), and in Form Names, a list of what will be stored + in the database. The data is stored in the database joined on a new line. +
          • Radio: This generates a radio option list. You must enter into Form Names the value that will be stored in the database, + and in Form Values, the value that will be displayed. +
          • Text: This generates a simple text box. You can set the size of text box using Form Size. +
          • Textarea: This generates a textarea field. You can set the rows and columns to use in the Form Size by entering rows,cols + (for example: 30,4). +
          • Password: This generates a password box. You can set the size of password box using Form Size. +
          • File: This creates a standard file field. You must set the File Save Location and set the database type to CHAR. +
          +
        • Form Size: This is only useful for select, text or textarea form types. For selects, set this to 0 to be a single + select field, set it to a postive number to be a multi select field. For Text fields, set this to the size of the text box, for + textarea types, set this to rows,cols to specify the size. +
        • Form Names: This is only useful for Select, Checkbox or Radio types. This is what will be stored in the database. You + should enter one value per line. +
        • Form Values: This is only useful for Select, Checkbox or Radio types. This is what will be displayed to the user. You should + enter one value per line. + +
        • File Save Location: Specifies in which directory where the the files are saved. Once you have set this, please try not to + change the save path. If you must, do not move the existing files unless you are prepared to prepared to update your + "@{[$self->{table}->name()]}_Files" table to reflect the move. + +
        • File Save URL: If this directory is accessibly by URL, specjfiy the base url here. This will allow retrieval of the full URL + path to the file should you want to display the file for viewing or download. + +
        • File Save Method: Once this has been set, please do not change unless there are no files being handled by the system. + This option sets how the files are to be stored in the directory. If you expect many files to be uploaded, the system will + use a collection of different directories to store the files. This allows faster lookups for by the OS and experienced + users will be able to "symlink" some of the directories to other harddrives to distribute the load. + +
        • File Maximum Size: Caps the maximum number of bytes of files users can upload. + +
        • Form Regex: This is a perl regular expression that data must match before being inserted or updated. +
        • Search Weight: If this is set to a positive value, this field will be included in the search index. Note: you must + rebuild the search index after changing/adding a search weight. +
        +

        +
        +
        + ~; + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + return; +} +END_OF_SUB + +## +# $self->editor_import_data_form; +# ------------------------------- +# Prints the page to import data. +## +$COMPILE{editor_import_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + my $table = $self->{record}; + + + print $self->_start_html ( { title => "Table Editor: $table" }); + print $self->_header ("Table Editor", $msg || "Import Data to $table."); + print $self->_start_form ( { do => 'editor_import_data', db => $self->{cgi}->{db} }, { name => 'ImportForm'}); + + +print qq~ + +~; + + print qq~ +
        +

        You can either import from a file or you can cut and paste the contents into a textarea box. If you + have a large number of records, you should really import from a file. If you use quick mode, the file must contain the same + number of fields as the current table, and in the same order. If you don't use quick mode, the first line of either the file + or the text box must be a list of column names!
        +   +

        + +
        +
        + Fields to Import
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        +
        + + ~; + + print qq| +
        +
        +
        +

        + Import data from file: or from textarea box:
        +
        + Use as delimiter. + Delete old data first +
          +

        + ~; + print $self->_buttons ("Import Data into"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_import_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data { +# -------------------------------------------------------- +# Import data from textarea box or file. +# + my $self = shift; + my ($delim, $file, $text, $res, @header); + + $delim = $self->{cgi}->{'import-delim'} || return $self->editor_import_data_form ("No import delimiter specified!"); + $file = $self->{cgi}->{'import-file'}; + $text = $self->{cgi}->{'import-text'}; + +# Make sure they have picked the fields to import + $self->{cgi}->{'ImportRight'} or return $self->editor_import_data_form ("No fields selected to import"); + @header = reverse ((ref ($self->{cgi}->{'ImportRight'}) eq 'ARRAY') ? @{$self->{cgi}->{'ImportRight'}} : $self->{cgi}->{'ImportRight'}); + + my $todo = 0; + for (@header) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_import_data_form("No fields selected to import") } + +# Make sure there is some data to import + $file or $text or return $self->editor_import_data_form("You must enter at least a filename or data in the textarea box."); + $file and $text and return $self->editor_import_data_form("Please only enter either a filename or data in the textarea box, not both."); + $delim = "\t" if $delim eq '\t'; + +# Store the lines to import in @lines and the header in $header. + my ($good_cnt, $err_cnt, $line, $line_num, @lines, @data, $error, %record, $i); + if ($file) { + open (FILE, "<$file") or return $self->editor_import_data_form("Unable to open file '$file': $!"); + local $/; + @lines = split /[\r\n]+/, ; + close FILE; + } + else { + @lines = split /[\r\n]+/, $text; + } + +# Remove old data if requested. + my $table = $self->{cgi}->{db}; + if ($self->{cgi}->{'import-delete'}) { + $self->{table}->delete_all; + } + +# Do the import. + $good_cnt = $err_cnt = 0; + LINE: for my $line_num (0 .. $#lines) { + ($err_cnt > 10) and last LINE; + $line = $lines[$line_num]; + @data = split /\Q$delim\E/, $line, -1; + if ($#data != $#header) { + $error .= "

      • " . ($line_num+2) . ": Row count: " . ($#data+1) . + " does not match header count: (@data) (@header)" . ($#header+1) . "\n"; + $err_cnt++; + next LINE; + } + $i = 0; + %record = map { $header[$i] => $data[$i++] } @data; + unless ($line_num){ # check the first line and ignore it if this is a header line + my @check_diff = grep $record{$_} ne $_ => @data; + (@check_diff) or next LINE; + } + if (!$self->{table}->add (\%record, 1)) { + $error .= "
      • " . ($line_num+2) . ": Failed validation. Error:
          $GT::SQL::error
        \n"; + $err_cnt++; + next LINE; + } + $good_cnt++; + } + +# Return the results. + if ($error) { + return $self->editor_import_data_form (($err_cnt >= 10) ? + "Aborting, too many errors!

        Rows imported: $good_cnt
        Errors with the following rows: +
          $error

        " : + "Rows imported: $good_cnt
        Errors with the following rows:
          $error

        "); + } + return $self->editor_import_data_form ("Rows imported: $good_cnt."); +} +END_OF_SUB + +## +# $self->editor_export_data_form; +# ------------------------------- +# Prints the page to export data. +## +$COMPILE{editor_export_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html ( { title => "Table Editor: $table" }); + print $self->_header ("Table Editor", $msg || "Export Data from $table."); + +print qq~ + +~; + print $self->_start_form ( { do => 'editor_export_data', db => $self->{cgi}->{db} }, {name => 'ExportForm'}); + + print qq~ +
        +

        You can either export your data from $table table to the screen or to a file. + If you have a large amount of + data it is recommended to export the contents to a file. Quick mode should be + used when exporting to a file as it + uses the SQL server to do the exporting and is considerably faster.
          +

        + + + +
        +
        + Fields to Export
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        + ~; + + print qq| +
        +
          +
        + Export data to: + filename:
        + Use as delimiter. +
        +
        + ~; + print $self->_buttons ("Export Data from"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_export_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data { +# -------------------------------------------------------- +# Export data to text file/screen. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my ($delim, $quick, $res); + + $self->{cgi}->{'ExportRight'} or return $self->editor_export_data_form ("No fields selected to export."); + my @order = reverse ((ref ($self->{cgi}->{'ExportRight'}) eq 'ARRAY') ? @{$self->{cgi}->{'ExportRight'}} : $self->{cgi}->{'ExportRight'}); + + my $todo = 0; + for (@order) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_export_data_form ("No fields selected to Export.") } + + $delim = $self->{cgi}->{'export-delim'}; + ($delim eq '\t') and ($delim = "\t"); + + if ($self->{cgi}->{'export-mode'} eq 'file') { + $self->{cgi}->{'export-file'} or return $self->editor_export_data_form ("Please enter a file name!"); + $editor->export_data ( + { + file => $self->{cgi}->{'export-file'}, + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form ($GT::SQL::error); + return $self->editor_export_data_form ("Data has been exported to: $self->{cgi}->{'export-file'}"); + } + else { + print $self->{in}->header; + $editor->export_data ( + { + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form ($GT::SQL::error); + return; + } +} +END_OF_SUB + +# ================================================================================ # +# PRIVATE/INTERNAL METHODS # +# ================================================================================ # + +## +# $self->_check_opts; +# ------------------- +# This checks to make sure the user specified at least one +# column to search on. +## +$COMPILE{_check_opts} = __LINE__ . <<'END_OF_SUB'; +sub _check_opts { + my $self = shift; + my $sel = 0; + +# Relation does not play fare :( + my $cols = $self->{table}->cols; + for (keys %{$self->{cgi}}) { $sel = 1 if (($self->{cgi}->{$_} =~ /\S/) and exists $cols->{$_}) } + if ((exists $self->{cgi}->{query} and $self->{cgi}->{query} =~ /\S/) or + (exists $self->{cgi}->{keyword} and $self->{cgi}->{keyword} =~ /\S/)) { + $sel = 1; + } + $sel or return; + return 1; +} +END_OF_SUB + +## +# $self->_header; +# --------------- +# Returns the header to be used with the forms, error pages, etc... +## +$COMPILE{_header} = __LINE__ . <<'END_OF_SUB'; +sub _header { + my ($self, $head, $msg) = @_; + if ($self->{header}) { + if (ref $self->{header} eq 'CODE') { + return $self->{header}->($self, $head, $msg); + } + else { + return $self->{header}; + } + } + else { + my $out = qq~ + + + + +
        + + + + + + + +
        + $self->{record}: $head +
        +

        $self->{record}: $head

        +

        $msg

        +
        +
        + ~; + } +} +END_OF_SUB + +## +# $self->_footer; +# --------------- +# Returns the footer to set for each form. +## +$COMPILE{_footer} = __LINE__ . <<'END_OF_SUB'; +sub _footer { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + if ($self->{footer}) { + if (ref $self->{footer} eq 'CODE') { + my $ret = $self->{footer}->($self); + return $ret if (defined $ret); + } + else { + return $self->{footer}; + } + } + my $url = GT::CGI->url( { query_string => 0 } ) . "?"; + my @vals = GT::CGI->param('db'); + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + my $ret = qq~ +
        +
        +
        $self->{record}: + Add | + Modify | + Delete | + Search + ~; + if (!exists $self->{table}->{tables}) { + $ret .= qq~ | + Properties + ~; + } + $ret .= qq~ +
        +
        + ~; + return $ret; +} +END_OF_SUB + +$COMPILE{_prop_navbar} = __LINE__ . <<'END_OF_SUB'; +sub _prop_navbar { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + my @vals = GT::CGI->param('db'); + my $url = GT::CGI->url( { query_string => 0 } ) . "?"; + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + return qq~ + +
        + + +
        Properties: + Add Column | + Delete Column | + Import Data | + Export Data | + Resync Database +
        +
        + ~; +} +END_OF_SUB + +## +# $self->_search_options; +# --------------- +# Returns the search options. +## +$COMPILE{_search_options} = __LINE__ . <<'END_OF_SUB'; +sub _search_options { + my $self = shift; + my $opts = shift; + if ($self->{search_options}) { + if (ref ($self->{search_options}) eq 'CODE') { + return $self->{search_options}->($self, $opts); + } + else { + return $self->{search_options}; + } + } + +# First, figure out the sort by columns. + my $c = $self->{table}->cols; + my ($hash, $order) = ({}, []); + foreach my $col (sort { + defined ($c->{$a}->{pos}) or warn "No pos for $a\n"; + defined ($c->{$b}->{pos}) or warn "No pos for $b\n"; + + $c->{$a}->{'pos'} <=> $c->{$b}->{'pos'} + } keys %$c) { + $hash->{$col} = $c->{$col}->{form_display} || $col; + push @$order, $col; + } + my $sb = $self->{html}->select ( + { + name => "sb", + values => $hash, + sort_order => $order, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $so = $self->{html}->select ( + { + name => "so", + values => { + 'ASC' => 'Ascending', + 'DESC' => 'Descending' + }, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $dr = $self->{html}->select ( + { + name => "dr", + values => { + '' => 'As Elements', + 'rows' => 'As Rows' + }, + default => $self->{cgi}->{dr}, + blank => 1 + } + ); + +# Then set the rest of the form options. + my $ma = exists $self->{cgi}->{ma} ? 'CHECKED' : ''; + my $mh = exists $self->{cgi}->{mh} ? $self->{cgi}->{mh} : 25; + my $kw = exists $self->{cgi}->{keyword} ? $self->{cgi}->{keyword} : ''; + my $idx = exists $self->{cgi}->{indexed} ? $self->{cgi}->{indexed} : ''; + + my $out = qq~ + +
        + + + + + + + + + + + + + + + + + + + + + ~; + + if ( ( () = $self->{in}->param('db') ) == 1 ) { + $out .= qq~ + + + + + ~; + } + + if (exists $opts->{modify_mult} and $opts->{modify_mult}) { + $out .= qq~ + + + + + ~; + } + $out .= qq~ +
        Maximum Hits:Match Any:
        Keyword Search:
        Indexed Search:
        Sort By:$sbUsing:$so
        Display Records:$dr
        Modify Multiple:
        +
        + ~; + return $out; +} +END_OF_SUB + +## +# $self->_start_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_form} = __LINE__ . <<'END_OF_SUB'; +sub _start_form { + my $self = shift; + my $opts = shift || {}; + my $meth = exists $opts->{method} ? $opts->{method} : 'POST'; + my $attrib = shift || {}; + +# If a code ref was specified execute it and return the output to be printed + if ($self->{start_form}) { + if (ref ($self->{start_form}) eq 'CODE') { + return $self->{start_form}->($self, $opts, $meth); + } + else { + return $self->{start_form}; + } + } + +# Get the variables that need to be preserved and generate hidden tags for them. + my $preserve = $self->preserve(); + my $hidden_tags = ''; + foreach my $p (keys %$preserve) { + $hidden_tags .= qq||; + } + + my $out = ''; my @vals; + my $url = GT::CGI->url ( { query_string => 0 } ); + my $att = ' '; + $attrib->{name} ||= 'admin'; + foreach (keys %{$attrib}) { $att .= qq|$_="$attrib->{$_}" | } + foreach my $key (keys %$opts) { + next if ($key eq 'method'); + my $val = $opts->{$key}; + (ref $val eq 'ARRAY') ? (@vals = @$val) : (@vals = ($val)); + foreach my $val2 (@vals) { + $self->{html}->escape(\$val2); + $out .= qq~~; + } + } + my $mimeenc = $self->{table}->_file_cols() ? 'enctype="multipart/form-data"' : ''; + return qq~

        $hidden_tags$out\n~; +} +END_OF_SUB + +## +# $self->_end_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_form} = __LINE__ . <<'END_OF_SUB'; +sub _end_form { + my $self = shift; + if (defined $self->{end_form} and $self->{end_form}) { + if (ref ($self->{end_form}) eq 'CODE') { + return $self->{end_form}->($self); + } + else { + return $self->{end_form}; + } + } + return "
        \n"; +} +END_OF_SUB + +## +# $self->_start_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_html} = __LINE__ . <<'END_OF_SUB'; +sub _start_html { + my $self = shift; + my $opts = shift || {}; + if ($self->{start_html}) { + if (ref ($self->{start_html}) eq 'CODE') { + return $self->{start_html}->($self, $opts); + } + else { + return $self->{start_html}; + } + } + my $title = exists $opts->{title} ? $opts->{title} : ''; + my $body = exists $opts->{body} ? $opts->{body} : $BODY; + return qq~\n$title: $self->{record}\n~; +} +END_OF_SUB + +## +# $self->_end_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_html} = __LINE__ . <<'END_OF_SUB'; +sub _end_html { + my $self = shift; + if ($self->{end_html}) { + if (ref ($self->{end_html}) eq 'CODE') { + return $self->{end_html}->($self); + } + else { + return $self->{end_html}; + } + } + return "\n\n"; +} +END_OF_SUB + +## +# $self->_buttons; +# ------------------------- +# Display closing table with form buttons. +## +$COMPILE{_buttons} = __LINE__ . <<'END_OF_SUB'; +sub _buttons { + my $self = shift; + my $name = shift; + return qq~ +
        +
        +
        + ~; +} +END_OF_SUB + +$COMPILE{_index_list} = __LINE__ . <<'END_OF_SUB'; +sub _index_list { + my ($self, $column) = @_; + my $indexed = $self->{cgi}->{index} || 'none'; + if ($column and ! $self->{cgi}->{index}) { + $indexed = + $self->{table}->_is_indexed($column) ? 'regular' : + $self->{table}->_is_unique($column) ? 'unique' : + $self->{table}->_is_pk($column) ? 'primary' : + 'none'; + } + if ($column and $indexed eq 'primary') { + return "Primary Key"; + } + my $output = '"; + return $output; +} +END_OF_SUB + +$COMPILE{_index_type} = __LINE__ . <<'END_OF_SUB'; +sub _index_type { + my ($self, $column) = @_; + my $indexed = 'none'; + if ($column) { + $self->{table}->_is_indexed($column) and ($indexed = 'regular'); + $self->{table}->_is_unique($column) and ($indexed = 'unique'); + $self->{table}->_is_pk($column) and ($indexed = 'primary'); + } + return $indexed; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Admin - instant admin for any sql table. + +=head1 SYNOPSIS + + my $cgi = new GT::CGI; + my $db = new GT::SQL '/path/to/def'; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process ( db => $db, cgi => $cgi ); + } + +=head1 DESCRIPTION + +GT::SQL::Admin provides an easy way to build a table/relation +management application. It provides all the HTML and code to +easily: + + 1. Add records + 2. Delete records + 3. Modify records + 4. Search records + 5. Add columns + 6. Drop columns + 7. Alter table properties + 8. Import data + 9. Export data + +all in about 6 lines of code. + +=head2 Usage + +To use GT::SQL::Admin you need to pass in an existing +L object, and a L object. + +In it's simplest usage, you can simply call: + + my $admin = new GT::SQL::Admin; + $admin->process ( db => $db, cgi => $cgi ); + +and the admin module will figure out what was requested and display +the appropriate screen. There is a $admin->for_me method that will +look to see if the cgi object contains something for the admin +to do, returning 1 if yes, 0 otherwise. You would then do: + + my $cgi = new GT::CGI; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process ( db => $db, cgi => $cgi ); + } + +You can also call any of the methods individually. You can create an +add form like: + + $admin->add_form; + +and it will be printed to STDOUT. + +To change the look of a page, you can pass in strings or code refs +to display any of the following items: + + start_html + header + start_form + end_form + footer + end_html + +and the admin will use your html/code when displaying. You can also pass +in to process: + + record => 'MyObject' + +and the admin will use that string when displaying titles like 'Add MyObject'. +If you don't specify, it will default to the name of the table. + +=head2 Subclassing the admin + +You can enhance the functionality of an admin quite easily. By default +GT::SQL::Admin expects to find a GT::SQL object, a GT::CGI object, and uses +internally a GT::SQL::Display::HTML object for any form/record html +generation. + +Alternatively, you can subclass one or more of the above and use your +own libraries. For instance, if you wanted to expand the form generation, +you could subclass the GT::SQL::Display::HTML object and override the display() +and form() method with your own. + +The admin will pass in a 'mode' to both display and form that will tell +you what it is using the form for. This can be one of: + + search_form + search_results + add_form + add_success + delete_search_form + delete_search_results + download_file + modify_search_form + modify_search_results + modify_form + modify_success + modify_multi_search_results + modify_multi_results_norec + modify_multi_result_changed + modify_multi_results_err + + +There are also several options that can be passed in. See the +L module for more information. + +Also be sure to read about subclassing in L. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Admin.pm,v 1.146 2005/03/15 00:35:29 brewt Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Base.pm b/site/glist/lib/GT/SQL/Base.pm new file mode 100644 index 0000000..ae703fb --- /dev/null +++ b/site/glist/lib/GT/SQL/Base.pm @@ -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; diff --git a/site/glist/lib/GT/SQL/Condition.pm b/site/glist/lib/GT/SQL/Condition.pm new file mode 100644 index 0000000..3850d41 --- /dev/null +++ b/site/glist/lib/GT/SQL/Condition.pm @@ -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 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 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 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 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 diff --git a/site/glist/lib/GT/SQL/Creator.pm b/site/glist/lib/GT/SQL/Creator.pm new file mode 100644 index 0000000..4b45b6d --- /dev/null +++ b/site/glist/lib/GT/SQL/Creator.pm @@ -0,0 +1,1216 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# Author : Scott Beck +# CVS Info : +# $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Creator; +# =============================================================== +use GT::SQL; +use GT::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $error $ERROR_MESSAGE/; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.74 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::Base/; +$DEBUG = 0; + +sub new { +# ------------------------------------------------------------------- +# Setup a new creator object. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = {}; + if (@_ == 0) { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). No arguments") } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (not @_ % 2) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). Wrong arguments") } + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH); No table passed in to creator."); + + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + + $self->debug("OBJECT CREATED") if $self->{_debug} > 2; + return $self; +} + +## +# $obj->create; +# ------------------- +# Checks to see that the table is not there. +# Returns undef if it is. If the table is not +# there creates the table. +# +# $obj->create("force"); +# ----------------------------- +# This will check to see if the table is there. +# If it is create_table will drop the table +# then create the current one. +## +sub create { + my $self = shift; + my $force = shift || 'check'; + my $opts = shift || {}; + + $self->{table}->connect() or return; +# Error checking + $self->{table}->check_schema or return; + keys %{$self->{table}->cols} or return $self->fatal('NOTABLEDEFS'); + if ($self->_uses_weights) { $self->_get_indexer()->pre_create_table() or return } + + my $table_name = $self->{table}->name(); + +# Force the creation if force is specified + if ($force eq 'force') { + $self->debug("Forcing the table creation") if $self->{_debug} > 1; + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + $self->debug("Table $table_name exists. Dropping table") if ($self->{_debug} > 1); + $self->drop_table; + } + else { + $self->debug("Not dropping table $table_name because it does not exist") if $self->{_debug} > 1; + } + } + elsif ($force eq 'check' or $force eq 'upgrade' ) { + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + if ( $force eq 'upgrade' ) { + return $self->_consolidate( $opts ); + } + else { + return $self->warn(TBLEXISTS => $table_name); + } + } + } + + $self->{table}->{driver}->create_table($force) or return; + + +# Set up some defaults + $self->set_defaults; + $self->{table}->save_state or return; + +# now that the table has been made, if the user has requested weighted-indexing of tables, handle that + if ($self->_uses_weights) { $self->_get_indexer()->post_create_table() or return } + +# then handle anything related to file databases + $self->_file_create_tables(); + return 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if $self->{_debug} > 2; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +$COMPILE{_file_create_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_create_tables { +# creates file upload tables if required + my $self = shift; + + if ( $self->{table}->_file_cols() ) { + +# ... create the table because we have file columns + require GT::SQL::File; + my $ftable = GT::SQL::File->new( + table => $self->{table}, + connect => $self->{connect} + ); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + + }; + $self->{table}->_file_cols(1); +} +END_OF_SUB + +sub set_defaults { + my $self = shift; + my %cols = ref $_[0] ? %{shift()} : $self->{table}->cols(); + my %file_defs = (form_type => 'FILE', form_size => '20', file_save_in => '.', file_save_scheme => 'HASHED'); + + for my $col (keys %cols) { + + my $attrib = $cols{$col}; + if ($attrib->{type} =~ /char/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + + if ($attrib->{form_type} and $attrib->{form_type} =~ /file/i) { + my $col_info = $self->{table}->{schema}->{cols}->{$col}; + for (qw(form_type form_size file_save_in file_save_scheme)) { + $col_info->{$_} ||= $file_defs{$_} unless $col_info->{$_}; + } + + $col_info->{file_log_path} ||= $col_info->{file_save_in}; + } + } + elsif ($attrib->{type} =~ /text|blob/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXTAREA'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 30; + } + elsif ($attrib->{type} =~ /int|double|float/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 10; + } + elsif ($attrib->{type} =~ /enum/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'SELECT'; + } + elsif ($attrib->{type} =~ /date|timestamp/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'DATE'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + } + } + +} + + +## +# $obj->load_table; +# ----------------- +# Creates a schema based on an existing sql +# table and saves it. +## +$COMPILE{load_table} = __LINE__ . <<'END_OF_SUB'; +sub load_table { + my $self = shift; + $self->{table}->connect() or return; + $self->_load_table(@_) or return; + $self->{table}->save_state() or return; +} +END_OF_SUB + +$COMPILE{_load_table} = __LINE__ . <<'END_OF_SUB'; +sub _load_table { + my $self = shift; + $self->debug("DESCRIBE $self->{table}->{name}") if $self->{_debug}; + my $sth = $self->{table}->{driver}->prepare("DESCRIBE $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pos, %index, %unique, %cols, @pk, %other) = (1); + + # Default to the current ai value, if any, because some databases don't + # associate an increment to a value (such a postgres, where sequences are + # completely separate from tables and columns) + my $ai = $self->{table}->ai; + + my $table_name = $self->{table}->name; + my %col_case_map = map { lc $_ => $_ } keys %{$self->{table}->cols}; + my %index_case_map = map { lc $_ => $_ } keys %{$self->{table}->index}; + my %unique_case_map = map { lc $_ => $_ } keys %{$self->{table}->unique}; + +# Get the column defintions. + while (my $col = $sth->fetchrow_hashref) { + my $name = $col_case_map{lc $col->{Field}} || $col->{Field}; + my $type = $col->{Type}; + my $not_null = $col->{Null} ? 0 : 1; + my $default = ($col->{Default} and $col->{Default} ne 'NULL') ? $col->{Default} : undef; + $ai = $name if $col->{Extra} and $col->{Extra} =~ /AUTO/i; + $_ = $type; + + if (/^((?:var)?char)\((\d+)/i) { + %other = (type => uc $1, size => $2); + $other{binary} = 1 if /binary/i; + } + elsif (/^(var)?binary\((\d+)/i) { + %other = (type => "\U${1}char", size => $2); + $other{binary} = 1; + } + elsif (/^((?:tiny|small|medium|big)?int)/i) { + %other = (type => uc $1); + $other{zerofill} = 1 if /zerofill/i; + $other{unsigned} = 1 if /unsigned/i; + } + # decimal(10,5) + elsif (/^(?:decimal)\((\d+),\s*(\d+)\)/i) { + %other = (type => 'DECIMAL', precision => $1, scale => $2); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:double|float8)/i) { + %other = (type => 'DOUBLE'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:float|real)/i) { + %other = (type => 'REAL'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(datetime|date|timestamp|time|year|(?:tiny|medium|long)?(?:text|blob))/i) { + %other = (type => uc $1); + } + elsif (/^enum\('([^\)]+)'\)/i) { + %other = ( + type => 'ENUM', + values => [split /'\s*,\s*'/, $1] + ); + } + else { + return $self->fatal(BADTYPE => $type); + } + my %col = ( + pos => $pos, + %other + ); + $col{default} = $default if defined $default; + $col{not_null} = 1 if $not_null; + $cols{$name} = \%col; + $pos++; + } + + # Retrieve index information + $sth = $self->{table}->{driver}->prepare("SHOW INDEX FROM $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pk_index_name, @pk_index_cols); + while (my $index = $sth->fetchrow_hashref) { + my $name = lc $self->{table}->{driver}->extract_index_name($self->{table}->{name}, $index->{index_name}); + $name = ($index->{index_unique} ? $unique_case_map{$name} : $index_case_map{$name}) || $name; + my $field = $col_case_map{lc $index->{index_column}} || $index->{index_column}; + if ($index->{index_primary}) { + push @pk, $field if $index->{index_primary}; + # Ignore primary indexes that we don't know about because pk's CAN + # overlap regular indexes in some databases + next unless exists $unique_case_map{$name} or exists $index_case_map{$name}; + } + if ($index->{index_unique}) { + push @{$unique{$name}}, $field; + } + else { + push @{$index{$name}}, $field; + } + } + + my $old_cols = $self->{table}->cols; + for my $col (keys %cols) { + for my $val (keys %{$old_cols->{$col}}) { + $cols{$col}->{$val} = $old_cols->{$col}->{$val} unless exists $cols{$col}->{$val}; + } + } + $self->{table}->cols(\%cols); + $self->{table}->pk(@pk); + $self->{table}->ai($ai || ''); + $self->{table}->index(\%index); + $self->{table}->unique(\%unique); + + return 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + require GT::SQL::Editor; +# Were ->{fk} there, Editor would wipe the current table from all fk_tables + my $fk = delete $self->{table}->{schema}->{fk}; + my $ret = GT::SQL::Editor->new( + debug => $self->{_debug}, + table => $self->{table}, + connect => $self->{table}->{connect} + )->drop_table(@_); + $self->{table}->{schema}->{fk} = $fk; + $ret; +} +END_OF_SUB + +## +# $obj->clear_schema +# ------------------ +# Resets the schema to an empty schema. +## +sub clear_schema { + my $self = shift; + + %{$self->{table}->{schema}} = ( + index => {}, + unique => {}, + cols => {}, + pk => [], + fk => {}, + subclass => {}, + ai => '', + fk_tables => [] + ); + $self->{table}->{search_driver} = 'NONINDEXED'; +} + +## +# $obj->cols($hash_ref); +# --------------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# -------------------------- +# Sets the relations columns as specified via method +# params. +## +sub cols { + my $self = shift; + return $self->{table}->cols(@_); +} + +## +# $obj->pk($array_ref); +# -------------------------- +# Sets relation primary key, $array_ref is the +# reference to an array which looks like +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# ------------------------------------- +# Sets relation primary key given the fields +# which are in parameter. +## +sub pk { + my $self = shift; + $self->{table}->pk(@_) or return; + return 1; +} + +## +# $obj->ai($column); +# ----------------------- +# Sets the AUTO INCRIMENT column. +## +sub ai { + my $self = shift; + $self->{table}->ai(@_) or return; + return 1; +} + +## +# $obj->name($table_name); +# ----------------------------- +# Sets the name for the table to create. +## +sub name { + my $self = shift; + $self->{table}->name(@_) or return; + return 1; +} + +## +# $obj->form_display($nice_name); +# ------------------------ +# Sets the name of the table as it is displayed +# using the Display module. +## +sub form_display { + my $self = shift; + $self->{table}->form_display(@_) or return; + return 1; +} + +## +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index( +# { +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# } +# ); +# ---------------------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +## +sub index { + my $self = shift; + $self->{table}->index(@_) or return; + return 1; +} + +## +# $obj->search_driver( $searching_driver ); +# -------------------------------------------------- +## +sub search_driver { + my $self = shift; + $self->{table}->search_driver(@_) or return; + return 1; +} + +## +# $obj->unique($index_name, $col1, ..., $coln); +# -------------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +## +sub unique { + my $self = shift; + $self->{table}->unique(@_) or return; + return 1; +} + +## +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_1, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ----------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME => { SOURCE_FIELD_1 => TARGET_FIELD }); +# -------------------------------------------------------------- +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +sub fk { + my $self = shift; + $self->{table}->fk(@_) or return; + return 1; +} + +sub subclass { return shift->{table}->subclass(@_) } + +## +# $obj->save_schema +# Saves the schema (.def) file. Useful when loading tables +# that already exist, but you don't want to overwrite. +## +sub save_schema { + return unless ($_[0]->{table}); + return $_[0]->{table}->save_state(); +} + +$COMPILE{_consolidate} = __LINE__ . <<'END_OF_SUB'; +sub _consolidate { +#------------------------------------------------------------------------------- + my $self = shift; + my $opts = shift; + my $long_name = $self->{table}->{name}; + my $table_name = $long_name; + my $prefix = $self->{connect}->{PREFIX}; + $table_name =~ s,^$prefix,,; + + my $file = "$self->{connect}->{def_path}/$long_name.def"; + +# $self->clear_schema(); + my $table = $self->{table}->table( $table_name ) or die $GT::SQL::error; + + $table->connect(); + my $source = $table->{schema}; + my $destination = $self->{table}->{schema}; + +# HANDLE COLUMNS + my $s_cols = $source->{cols}; + my $d_cols = $destination->{cols}; + +# special vars + my ( %POSITION, %CHANGED, %REMOVED, %ADDED ); + +# compare the table columns from source to destination + my ( $cols, %col_order ); + %col_order = map { $_ => $s_cols->{$_}->{'pos'} } keys %$s_cols; + + for my $col_name ( keys %col_order ) { + + if ( $d_cols->{$col_name} ) { + + if ( _is_different( $d_cols->{$col_name}, $s_cols->{$col_name} ) ) { + + for my $option ( %{$d_cols->{$col_name}} ) { + + my $d_opts = $d_cols->{$col_name}; + my $s_opts = $s_cols->{$col_name}; + + if ( $option eq 'pos' ) { + if ( $d_opts->{pos} != $s_opts->{pos} ) { + $POSITION{$col_name} = $d_opts; + }; + } + + elsif ( ref $d_opts->{$option} eq 'ARRAY' ) { + my $d_ar = $d_opts->{$option}; + my $s_ar = $s_opts->{$option}; + if ( @$d_ar != @$s_ar ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + else { + for my $index ( 0..( scalar(@$d_ar)-1 ) ) { + if ( $d_ar->[$index] != $s_ar->[$index] ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + } + } + } + + else { + ( $d_opts->{$option} ne $s_opts->{$option} ) and $CHANGED{$col_name} = $d_cols->{$col_name}; + } + + } + + } + + } + + else { + $REMOVED{$col_name} = $s_cols->{$col_name}; + }; + + } + +# compare the table columns from destination to source + %col_order = map { $_ => $d_cols->{$_}->{'pos'} } keys %$d_cols; + for my $col_name ( keys %col_order ) { + if ( !$s_cols->{$col_name} ) { + $ADDED{$col_name} = $d_cols->{$col_name}; + } + } + +# HANDLE INDEXES + my $d_idx = $destination->{index}; + my $s_idx = $source->{index}; + my %index_order = map { $_ => 1 } ( keys %$d_idx, keys %$s_idx ); + my %INDEXES = (); + for my $idx_name ( keys %index_order ) { + if ( $d_idx->{$idx_name} and $d_idx->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_idx->{$idx_name} || []}; + my $d_cols = join "|", sort @{$s_idx->{$idx_name} || []}; + if ( $s_cols ne $d_cols ) { + $INDEXES{$idx_name} = $d_idx->{$idx_name}; + } + else { + $INDEXES{$idx_name} = 'EQ'; + } + } + elsif ( !$d_idx->{$idx_name} and $s_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'REMOVED'; + } + elsif ( !$s_idx->{$idx_name} and $d_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'ADDED'; + } + } + +# HANDLE AUTOINCREMENT + my $AI = undef; + if ( $destination->{ai} eq $source->{ai} ) { + $AI = 'EQ'; + } + else { + $AI = $destination->{ai}; + } + +# HANDLE PK + my $PK = undef; + $d_cols = join "|", sort @{$destination->{pk} || []}; + $s_cols = join "|", sort @{$source->{pk} || []}; + if ( $d_cols eq $s_cols ) { + $PK = 'EQ'; + } + else { + $PK = $destination->{pk}; + } + +# HANDLE FK + my %FK = (); + my $d_fk = $destination->{fk}; + my $s_fk = $source->{fk}; + %index_order = map { $_ => 1 } ( keys %$d_fk, keys %$s_fk ); + for my $col_name ( keys %$d_fk ) { + if ( _is_different( $d_fk->{ $col_name }, $s_fk->{ $col_name } ) ) { + $FK{$col_name} = $s_fk->{ $col_name }; + } + else { + $FK{$col_name} = 'EQ'; + } + } + +# HANDLE SUBCLASS + my %SUBCLASS = (); + my $d_sc = $destination->{subclass}; + my $s_sc = $source->{subclass}; + %index_order = map { $_ => 1 } ( keys %$d_sc, keys %$s_sc ); + for my $key ( keys %index_order ) { + if ( _is_different( $d_fk->{ $key }, $s_fk->{ $key } ) ) { + $SUBCLASS{ $key } = $d_fk->{ $key } ; + } + else { + $SUBCLASS{ $key } = 'EQ'; + } + } + +# HANDLE UNIQUE + my $d_uni = $destination->{unique}; + my $s_uni = $source->{unique}; + my %unique_order = map { $_ => 1 } ( keys %$d_uni, keys %$s_uni ); + my %UNIQUE = (); + for my $idx_name ( keys %unique_order ) { + if ( $d_uni->{$idx_name} and $d_uni->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_uni->{$idx_name}}; + my $d_cols = join "|", sort @{$s_uni->{$idx_name}}; + if ( $s_cols ne $d_cols ) { + $UNIQUE{$idx_name} = $d_uni->{$idx_name}; + } + else { + $UNIQUE{$idx_name} = 'EQ'; + } + } + elsif ( !$d_uni->{$idx_name} and $s_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'REMOVED'; + } + elsif ( !$s_uni->{$idx_name} and $d_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'ADDED'; + } + }; + +# Summon callback if required + $opts->{callback} and ( &{$opts->{callback}}( $self, $table, \%POSITION, \%CHANGED, \%REMOVED, \%ADDED, \%INDEXES, $AI, $PK, \%SUBCLASS, \%UNIQUE ) or return ); + +# if position movements are required we must read all the data into a temp +# table first + my $DO_POSITION = 0; + $DO_POSITION = $self->_create_temp_table( $table ); + +# ... change columns drop the columns + my $sth = $table->do_query(qq!DROP TABLE $long_name!) or die $GT::SQL::error; + +# change the columns that have to be changed. + $self->create( 'force' ) or die $GT::SQL::error; + +# ... add the columns that have been removed in the past + if ( %REMOVED and $self->{carry_over_columns} ) { + my $editor = $self->{table}->editor($table_name); + my $pos = scalar( keys %{$destination->{cols}} ); + for my $col_name ( sort { $REMOVED{$a}->{pos} <=> $REMOVED{$b}->{pos} } keys %REMOVED ) { + $REMOVED{$col_name}->{pos} = ++$pos; + $editor->add_col( $col_name, $REMOVED{$col_name} ) or die $GT::SQL::error; + } + } + +# ... now copy the data over + $cols = $source->{cols}; + my $copy_cols = join ",", + sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } + grep { $self->{carry_over_columns} ? 1 : not $REMOVED{$_} } + keys %$cols; + $table->do_query(qq! + INSERT INTO $long_name + ($copy_cols) + SELECT $copy_cols + FROM $DO_POSITION + !) or die $GT::SQL::error; + + if ( %CHANGED ) { + my $editor = $self->{table}->editor($table_name); + for my $col_name ( keys %CHANGED ) { + $editor->alter_col( $col_name, $CHANGED{$col_name} ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_create_temp_table} = __LINE__ . <<'END_OF_SUB'; +sub _create_temp_table { +#------------------------------------------------------------------------------- +# + my $self = shift; + my $table = shift; + my $source = $table->{schema}; + my $def_path = $self->{connect}->{def_path}; + + use GT::MD5; + my $table_name = ''; + while ( -e ( $def_path . ( $table_name = GT::MD5::md5_hex( time() * rand() * 10000 ) ) ) ) {}; + my $c = $table->creator( $table_name ); + my $struct = _copy_struct( $source ); + $struct->{fk_tables} = {}; + $struct->{fk} = {}; + $struct->{subclass} = {}; + for ( values %{$struct->{cols}} ) { delete $_->{weight}; } + + $c->cols( %{$struct->{cols}} ); + %{$c->{table}->{schema}} = %$struct; + $c->create( "force" ) or die $GT::SQL::error; + + my $tbl = $table->table( $table_name ); + my $s_name = $table->name(); + my $d_name = $tbl->name(); + + $tbl->connect(); + $tbl->do_query(qq|INSERT INTO $d_name SELECT * FROM $s_name|) or die $GT::SQL::error; + + return $table_name; +} +END_OF_SUB + +$COMPILE{_copy_struct} = __LINE__ . <<'END_OF_SUB'; +sub _copy_struct { +#------------------------------------------------------------------------------- +# + my $source = shift; + my $copied_struct = undef; + + if ( ref $source eq 'HASH' ) { + $copied_struct = {}; + for my $key ( keys %$source ) { + $copied_struct->{ $key } = _copy_struct( $source->{$key} ); + } + } + + elsif ( ref $source eq 'ARRAY' ) { + $copied_struct = []; + for my $element ( @$source ) { + push @$copied_struct, _copy_struct( $element ); + } + } + + else { + $copied_struct = $source; + } + + return $copied_struct; +} +END_OF_SUB + + +$COMPILE{_is_different} = __LINE__ . <<'END_OF_SUB'; +sub _is_different { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return 1 } + + if ( ref $source eq 'HASH' ) { + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + for my $key ( keys %keys ) { + _is_different( $source->{$key}, $destination->{$key} ) and return 1; + } + } + + elsif ( ref $source eq 'ARRAY' ) { + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + my $count = ( $ca > $cb ) ? $ca : $cb; + for my $index ( 0 .. ( $count - 1 ) ) { + _is_different( $source->[$index], $destination->[$index] ) and return 1; + } + } + + else { + ( $source ne $destination ) and return 1; + } + + return; +} +END_OF_SUB + +$COMPILE{_compare} = __LINE__ . <<'END_OF_SUB'; +sub _compare { +#------------------------------------------------------------------------------- +# takes a hashref or arrayref and compares the two +# + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return [ 'NE_TYPES', ref $source, ref $destination ]; } + + if ( ref $source eq 'HASH' ) { + return _comp_hash( $source, $destination ); + } + elsif ( ref $source eq 'ARRAY' ) { + return _comp_array( $source, $destination ); + } + else { + return; + } + +} +END_OF_SUB + +$COMPILE{_comp_hash} = __LINE__ . <<'END_OF_SUB'; +sub _comp_hash { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my %errs; + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + + for my $key ( keys %keys ) { + + my $src = $source->{$key}; + my $dst = $destination->{$key}; + if ( ref $src or ref $dst ) { + $errs{$key} = _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + $errs{$key} = 'EQ'; + } + else { + $errs{$key} = [ 'NE', $src, $dst ]; + } + + } + + return \%errs; +} +END_OF_SUB + +$COMPILE{_comp_array} = __LINE__ . <<'END_OF_SUB'; +sub _comp_array { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my @errs; + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + + my $count = ( $ca > $cb ) ? $ca : $cb; + + for my $index ( 0 .. ( $count - 1 ) ) { + + my $src = $source->[$index]; + my $dst = $destination->[$index]; + if ( ref $src or ref $dst ) { + push @errs, _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + push @errs, 'EQ'; + } + else { + push @errs, [ 'NE', $src, $dst ]; + } + + } + + return \@errs; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Creator - an object to create SQL tables. + +=head1 SYNOPSIS + + my $creator = $DB->creator('Newtable'); + $creator->cols( + col1 => { + pos => 1 + type => 'CHAR', + size => 50 + }, + col2 => { + pos => 2, + type => 'INT', + not_null => 1 + } + ); + $creator->pk('col2'); + $creator->ai('col2'); + $creator->create or die "Unable to create: $GT::SQL::error"; + +=head1 DESCRIPTION + +A creator object is used to build new SQL tables. + +To get a new creator object, you need to call creator() from an existing +GT::SQL object. + +The object that is returned has methods to set up your table. You will need to +call this method for each table you want to create. + + $creator = $obj->creator($table); + +You must pass in the name of the table you want to create. This means if you +have a table named C you must call C<-Ecreator> with C<'MyTable'> +as the argument. + + $creator = $obj->creator('MyTable'); + +From this point you can call create methods on your creator object to define +and create your table. + +=head2 cols + +I is used to define the columns that will be in the new table by setting +properties such as the type, whether it allows null values, unsigned etc. + +For detailed information on the types and options accepted, please see +L. The following describes the options accepted that do not +directly affect the underlying database: + +=over 4 + +=item values + +This specifies the values for the I column type. If you are using an +I this must be set. The value for this should be an array reference of +the possible values for the I column. The values in the array that is +passed in will be quoted by DBI's quote method. + +=item regex + +This is a regex that the value must pass before being inserted +into the database. + +=item form_display + +This is a "pretty name" that will be used by the HTML module +for creating attractive forms automatically. + +=item form_size + +This is the form field length to be used by the HTML module. + +=item form_type + +This is the type of form to use by the HTML module: select, checkbox +radio, text, textarea or hidden. + +=item form_names + +This is for multi select or checkboxes and is an array ref of names +that get displayed. + +=item form_values + +This is for multi select or checkboxes and is an array ref of the +actual values that will be stored in the database. + +=item time_check + +This is only useful for TIMESTAMP fields. If set to 1, the module +will not allow you to update a record which has an older timestamp +then what is in the database. This is very helpful for protecting +against multiple updates. + +=item weight + +By giving an item a weight, GT::SQL will maintain a search index +table, and use that search index table when called using query. +This is only useful for indexing large text fields and should not +be used normally. The higher the weight, the more influence that +column will have on the result. So if a Title was set to weight +3 and a Description to weight 1, then when doing a search, a match +in the title would make the result appear before a match in the +description. + +=back + +So an example would look like: + + $creator->cols( + $col1 => { + type => 'ENUM', + values => ['val1', 'val2' ... ], + not_null => 1 + }, + $col2 => { + ... + } + ); + +Sets the relations columns as specified via method +parameters. The only required key for the has is type. +However some column types require other values be set +such as I requires you specify the values. + +=head2 pk + +C lets you specify the primary keys for the current table. +This method can be called with an array of primary key columns +in which case all the specified column names in the array will +make up the primary keys. If you call it with a single scalar +value this is assumed to be the primary key for the table. + + $creator->pk($field1, $field2, ...); + +=head2 ai + +This specifies the auto increment column for the current table. +There can be only one auto increment column per table, it must +be a numeric type, it must be not null and it must be the +primary key. This limitation is checked when you call create. +If it is not a numeric column type you will get a fatal error +when you call create. If any of the other limitations fail +the creator class will correct. + +=head2 index + +C allows you to specify the name and the columns for you +table indexes. + +There are two ways to call this method. + +You can set up all your indexes at once by calling it with +hash reference like this: + + $creator->index({ + $index1 => [field1, field2], + $index2 => [field3, field4] + }); + +The keys to this hash reference are the index names and +the values are an array reference containing the columns +that are part of the named index. The order for these +columns are maintained during the create. + +You can also pass in one index at a time like this; + + $creator->index($index_name, $col1, ..., $coln); + +The first argument is the name of the index and all the +rest are treated as columns that are part of this index. +Again the order of the columns are maintained. + +=head2 unique + +The C method allows you to specify the unique +indexes for the current table. This method takes the +same arguments as the C method. + +=head2 fk + +C allows you to specify foreign key relations for your +tables. You CAN NOT specify foreign keys for tables that +have not been created yet. There are two ways to pass in +arguments to C. The first way is passing in a hash reference. + + $creator->fk({ + $FOREIGN_TABLE_NAME => + { + $LOCAL_TABLE_COL_1 => $FOREIGN_TABLE_COL_1, + ... + $LOCAL_TABLE_COL_n => $FOREIGN_TABLE_COL_n + } + }); + +The keys to the hash are the names of the tables you are relating to. +The values are a hash reference that contain the name of the current +tables columns as the keys and the name of the foreign tables columns +that we are relating to as the values. + +You cannot relate fields to your self. You also need to be careful +not to create circular references. This is checked when you call this +method. If there is a circular reference detected you will receive a +fatal error. + +Foreign keys currently effect selects only. + +=head2 search_driver + +This affects how the weighted records are indexed. By default the +system will attempt to use best driver for the DBMS. However, if +you'd like to force the indexing system to an alternative type, such +as for MYSQL you can use this. + +* note: though the MYSQL driver is faster, the internal indexing system +has better support for phrase searching and keyword searching. + +To set the driver, call C with the appropriate driver +name. The following example will force the system into using the +internally implemented indexing scheme. + + $creator->search_driver('INTERNAL'); + +Currently, the only other valid option is "MYSQL". + +-note- + +The MYSQL driver occasionally behaves oddly with a small number of +records. In that case, set the search scheme to "INTERNAL". + +=head2 create + +This is the method you call to create your table after you have specified +all your table definitions. Several checks are made when this method is +called to ensure the table is created correctly. + +One of the things that is done is checking to see that the table you are +trying to create does not exist. If the table does exist I will +return undefined and set the error in $GT::SQL::error. + +You can specify to have C drop the table by passing in "force". + + $creator->create('force'); + +-or- + + $creator->create; + +C returns true on success and undef on failure. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Display/HTML.pm b/site/glist/lib/GT/SQL/Display/HTML.pm new file mode 100644 index 0000000..783f0d6 --- /dev/null +++ b/site/glist/lib/GT/SQL/Display/HTML.pm @@ -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~~; +} + +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~\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 ~) and next KEY; + } + $out .= qq~$val ~; + } + 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~ $val~) and next KEY; + } + $out .= qq~ $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~~; +} + +sub hidden_text { + my ($self, $opts) = @_; + my $out; + my $html = $self->_get_html_display; + $out .= "{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~~; + 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!!; + $sfname and $out .= qq!!; + + 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}>download!; + $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}>view!; + } + $out .= qq~ Delete~; + } + } + my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : ""; + $out .= qq~

        ~; + + 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~~; +} + +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~~; +} + +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~~; +} + +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 .= "
        "; + } + } + } + + 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}>download!; + + $url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] ); + $val .= qq! {font}>view!; + } + + 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~[<<] ~); + ($nh > 1) and ($url .= qq~[<] ~); + 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~$i ~); + if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; } + } + $url .= qq~[>] ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits)); + $url .= qq~[>>] ~ 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; +} + +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. diff --git a/site/glist/lib/GT/SQL/Display/HTML/Relation.pm b/site/glist/lib/GT/SQL/Display/HTML/Relation.pm new file mode 100644 index 0000000..e549e59 --- /dev/null +++ b/site/glist/lib/GT/SQL/Display/HTML/Relation.pm @@ -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 .= '
        '; + + 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~~; + } + $self->{extra_table} and ($out .= "\n"); + return $out; +} + +sub mk_table { + my $self = shift; + my %opt = @_; + + my $out = ''; + $self->{extra_table} and ($out .= "

        "); + my $cols = $opt{table}->cols; + my $name = $opt{table}->name; + + $out .= qq( + {table}> + + ); + 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 .= "
        + $name +
        \n"; + $out .= "

        \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}>{td} width='$opt{cwidth}'>{col_font}>$display_name{td} width='$opt{vwidth}'>{val_font}>"; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self ); + + $out .= ""; + +# 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} width="10%">{val_font}>~; + $out .= $self->_mk_search_opts({ + name => $field_name, + def => $self->{cols}->{$col}, + pk => $is_pk + }) || ' '; + $out .= ""; + } + $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 diff --git a/site/glist/lib/GT/SQL/Display/HTML/Table.pm b/site/glist/lib/GT/SQL/Display/HTML/Table.pm new file mode 100644 index 0000000..7482469 --- /dev/null +++ b/site/glist/lib/GT/SQL/Display/HTML/Table.pm @@ -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 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{col_font}>!; + $out .= 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" ) : '' ) . ""; + $out .= qq!\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{col_font}>!; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }); + + $out .= qq!\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 .= "
        "); + $out .= "{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}>"; + +# Display any search options if requested. + if ($self->{search_opts}) { + $out .= qq~"; + } + $out .= "\n"; + } + $out .= "
        {td} width='$cwidth'>{col_font}>$display_name{td} width='$vwidth'>{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 .= "{td} width="10%">{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 .= "
        \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~~; + } + $self->{extra_table} and ($out .= "
        \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 diff --git a/site/glist/lib/GT/SQL/Driver.pm b/site/glist/lib/GT/SQL/Driver.pm new file mode 100644 index 0000000..23e57b7 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver.pm @@ -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; diff --git a/site/glist/lib/GT/SQL/Driver/MSSQL.pm b/site/glist/lib/GT/SQL/Driver/MSSQL.pm new file mode 100644 index 0000000..7ab1990 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/MSSQL.pm @@ -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 <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(<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 < 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/
        /\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; diff --git a/site/glist/lib/GT/SQL/Driver/MYSQL.pm b/site/glist/lib/GT/SQL/Driver/MYSQL.pm new file mode 100644 index 0000000..d6ceea7 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/MYSQL.pm @@ -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; diff --git a/site/glist/lib/GT/SQL/Driver/ORACLE.pm b/site/glist/lib/GT/SQL/Driver/ORACLE.pm new file mode 100644 index 0000000..6ea4789 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/ORACLE.pm @@ -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(<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 <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/
        /\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; diff --git a/site/glist/lib/GT/SQL/Driver/PG.pm b/site/glist/lib/GT/SQL/Driver/PG.pm new file mode 100644 index 0000000..3017c51 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/PG.pm @@ -0,0 +1,643 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::PG +# CVS Info : +# $Id: PG.pm,v 2.2 2005/02/01 02:00:47 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: PostgreSQL driver for GT::SQL +# + +package GT::SQL::Driver::PG; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; +use DBI(); + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver/; + +sub protocol_version { 2 } + +sub dsn { +# ----------------------------------------------------------------------------- +# Creates a postgres-specific DSN, such as: +# DBI:Pg:dbname=database;host=some_hostname +# host is omitted if set to 'localhost', so that 'localhost' can be used for a +# non-network connection. If you really want to connect to localhost, use +# 127.0.0.1. +# + my ($self, $connect) = @_; + + $connect->{driver} ||= 'Pg'; + $connect->{host} ||= 'localhost'; + $self->{driver} = $connect->{driver}; + + my $dsn = "DBI:$connect->{driver}:"; + $dsn .= "dbname=$connect->{database}"; + $dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost'; + $dsn .= ";port=$connect->{port}" if $connect->{port}; + + return $dsn; +} + +sub hints { + prefix_indexes => 1, + fix_index_dbprefix => 1, + case_map => 1, + ai => sub { + my ($table, $column) = @_; + my $seq = "${table}_seq"; + my @q; + push @q, \"DROP SEQUENCE $seq"; + push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1"; + \@q; + }, + drop_pk_constraint => 1 +} + +$COMPILE{_version} = __LINE__ . <<'END_OF_SUB'; +sub _version { + my $self = shift; + return $self->{pg_version} if $self->{pg_version}; + my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION + if ($ver) { + local $^W; + $ver = sprintf "%.2f", $ver; + } + return $self->{pg_version} = $ver; +} +END_OF_SUB + +sub _prepare_select { +# ----------------------------------------------------------------------------- +# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format +# + my ($self, $query) = @_; + $query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i; + $query; +} + +sub _prepare_describe { +# ------------------------------------------------------------------ +# Postgres-specific describe code +# + my ($self, $query) = @_; + $query =~ /DESCRIBE\s*(\w+)/i + or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query"); + + # atttypmod contains the scale and precision, but has to be extracted using bit operations: + my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000) + my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000) + + <>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')' + ELSE t.typname + END AS "Type", + CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null", + ( + SELECT + CASE + WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#') + WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc + ELSE NULL + END + FROM pg_attrdef + WHERE adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Default", + ( + SELECT + CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END + FROM pg_attrdef d + WHERE d.adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Extra" +FROM + pg_class c, pg_attribute a, pg_type t +WHERE + a.atttypid = t.oid AND a.attrelid = c.oid AND + relkind = 'r' AND + a.attnum > 0 AND + c.relname = '\L$1\E' +ORDER BY + a.attnum +QUERY + +# The following could be used above for Key - but it's left off because SHOW +# INDEX is much more useful: +# ( +# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END +# FROM pg_index keyi, pg_class keyc, pg_attribute keya +# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid +# and indisprimary = 't' and keya.attname = a.attname +# ) AS "Key", +} + +sub column_exists { + my ($self, $table, $column) = @_; + my $sth = $self->{dbh}->prepare(< 0 AND + c.relname = ? AND a.attname = ? +EXISTS + $sth->execute(lc $table, lc $column); + + return scalar $sth->fetchrow; +} + +sub _prepare_show_tables { +# ----------------------------------------------------------------------------- +# pg-specific 'SHOW TABLES'-equivelant +# + <<' QUERY'; + SELECT relname AS tables + FROM pg_class + WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%') + ORDER BY relname + QUERY +} + +sub _prepare_show_index { +# ----------------------------------------------------------------------------- +# Get index list +# + my ($self, $query) = @_; + unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) { + return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query"); + } + <<" QUERY"; + SELECT + c.relname AS index_name, + attname AS index_column, + CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique, + CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary + FROM + pg_index i, + pg_class c, + pg_class t, + pg_attribute a + WHERE + i.indexrelid = c.oid AND + a.attrelid = c.oid AND + i.indrelid = t.oid AND + t.relname = '\L$1\E' + ORDER BY + i.indexrelid, a.attnum + QUERY +} + +sub drop_table { +# ----------------------------------------------------------------------------- +# Drops the table passed in - drops a sequence if needed. Takes a second +# argument that, if true, causes the sequence _not_ to be dropped - used when +# the table is being recreated. +# + my ($self, $table) = @_; + + my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'"); + $sth->execute(); + if (my $seq_name = $sth->fetchrow) { + $self->do("DROP SEQUENCE $seq_name") + or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error); + } + return $self->SUPER::drop_table($table); +} + +sub drop_column { +# ------------------------------------------------------------------- +# Drops a column from a table. +# + my ($self, $table, $column) = @_; + + my $ver = $self->_version(); + + # Postgresql 7.3 and above support ALTER TABLE $table DROP $column + return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03; + + $self->_recreate_table(); +} + +$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB'; +sub _recreate_table { +# ----------------------------------------------------------------------------- +# Adds/removes/changes a column, but very expensively as it involves recreating +# and copying the entire table. Takes argument pairs, currently: +# +# with => 'adding_this_column' # optional +# +# Keep in mind that the various columns depend on the {cols} hash of the table +# having been updated to reflect the change. +# +# We absolutely require DBI 1.20 in this subroutine for transaction support. +# However, we won't get here if using PG >= 7.3, so you can have either an +# outdated PG, or an outdated DBI, but not both. +# + my ($self, %opts) = @_; + + DBI->require_version(1.20); + my $ver = $self->_version; + + my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified'); + + my $cols = $self->{schema}->{cols}; + my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols; + + my (@copy_cols, @select_cols); + for (keys %$cols) { + push @copy_cols, "$_ " . $self->column_sql($cols->{$_}); + push @select_cols, $_; + } + + if ($opts{with}) { # a column was added, so we can't select it from the old table + @select_cols = grep $_ ne $opts{with}, @select_cols; + } + + $self->{dbh}->begin_work; + + my $temptable = "GTTemp" . substr(time, -4) . int rand 10000; + my $select_cols = join ', ', @select_cols; + my $lock = "LOCK TABLE $table"; + my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table"; + + my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable"; + my $drop_temp = "DROP TABLE $temptable"; + + for my $precreate ($lock, $createtemp) { + unless ($self->{dbh}->do($precreate)) { + $self->warn(CANTEXECUTE => $precreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + unless ($self->drop_table($table)) { + $self->{dbh}->rollback; + return undef; + } + + unless ($self->create_table) { + $self->{dbh}->rollback; + return undef; + } + + for my $postcreate ($insert, $drop_temp) { + unless ($self->{dbh}->do($postcreate)) { + $self->warn(CANTEXECUTE => $postcreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + $self->{dbh}->commit; + + return 1; +} +END_OF_SUB + +sub alter_column { +# ----------------------------------------------------------------------------- +# Changes a column in a table. The actual path done depends on multiple +# things, including your version of postgres. The following are supported +# _without_ recreating the table; anything more complicated requires the table +# be recreated via _recreate_table(). +# +# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20, +# everything else does) +# - adding/dropping a not null contraint, with >= 7.3 +# - any other changes, with >= 7.3, by adding a new column, copying data into +# it, dropping the old column +# +# Anything else calls _recreate_table(), which also requires DBI 1.20, but is +# much more involved as the table has to be dropped and recreated. +# + my ($self, $table, $column, $new_def, $old_col) = @_; + + my $ver = $self->_version; + return $self->_recreate_table() if $ver < 7; + + my $cols = $self->{schema}->{cols}; + my $new_col = $cols->{$column}; + + my @onoff = qw/not_null/; # true/false attributes + my @changeable = qw/default size scale precision/; # changeable attributes + my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff; + my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff; + my %change = map { ( + exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new + and ( + defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't + or + defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but != + ) + ) ? ($_ => 1) : () } @changeable; + + { + my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable; + my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable; + %add = (%add, %add_changeable); + %rem = (%rem, %rem_changeable); + } + + if ($ver < 7.03) { + # In 7.0 - 7.2, defaults can be added/dropped/changed, but anything + # more complicated needs a table recreation + if ( + keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default + or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default + or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default + ) { + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + my $ph; + if ($add{default} or $change{default}) { + $query .= "SET DEFAULT ?"; + $ph = $new_col->{default}; + } + else { + $query .= "DROP DEFAULT"; + } + $self->{dbh}->do($query, defined $ph ? (undef, $ph) : ()) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + return $self->_recreate_table(); + } + + # PG 7.3 or later + + if ( + keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL + or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL + ) { + # All we're doing is changing a not_null constraint + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + $query .= $rem{not_null} ? 'DROP' : 'SET'; + $query .= ' NOT NULL'; + $self->{dbh}->do($query) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + + if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8) + and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null + and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null + ) { + my @query; + # Change type (PG 8+ only) + if ($ver >= 8 and $change{type}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}"; + } + + # Change default + if ($add{default} or $change{default}) { + push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}]; + } + elsif ($rem{default}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT"; + } + + # Change not_null + if ($rem{not_null}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL"; + } + elsif ($add{not_null}) { + if ($add{default}) { + push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}]; + } + push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"; + } + + return $self->do_raw_transaction(@query); + } + + # We've got more complex changes than PG's ALTER COLUMN can handle; we need + # to add a new column, copy the data, drop the old column, and rename the + # new one to the old name. + my (@queries, %index, %unique); + + push @queries, "LOCK TABLE $table"; + my %add_def = %$new_col; + my $not_null = delete $add_def{not_null}; + my $default = delete $add_def{default}; + my $add_def = $self->column_sql(\%add_def); + my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000); + push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def"; + push @queries, "UPDATE $table SET $tmpcol = $column"; + push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default; + push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default; + push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null; + push @queries, "ALTER TABLE $table DROP COLUMN $column"; + push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column"; + + for my $type (qw/index unique/) { + while (my ($index, $columns) = each %{$new_col->{$type}}) { + my $recreate; + for (@$columns) { + if ($_ eq $column) { + $recreate = 1; + last; + } + } + next unless $recreate; + if ($type eq 'index') { + $index{$index} = $columns; + } + else { + $unique{$index} = $columns; + } + } + } + + $self->do_raw_transaction(@queries); + + while (my ($index, $columns) = each %index) { + $self->create_index($table, $index, @$columns); + } + while (my ($index, $columns) = each %unique) { + $self->create_unique($table, $index, @$columns); + } + + 1; +} + +sub add_column { +# ----------------------------------------------------------------------------- +# Adds a new column to the table. +# + my ($self, $table, $column, $def) = @_; + +# make a copy so the original reference doesn't get clobbered + my %col = %{$self->{schema}->{cols}->{$column}}; + +# Defaults and not_null have to be set _after_ adding the column. + my $default = delete $col{default}; + my $not_null = delete $col{not_null}; + + my $ver = $self->_version; + + return $self->_recreate_table(with => $column) + if $ver < 7 and defined $default or $ver < 7.03 and $not_null; + + my @queries; + + if (defined $default or $not_null) { + $def = $self->column_sql(\%col); + } + + push @queries, ["ALTER TABLE $table ADD $column $def"]; + + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default; + push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null; + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null; + + $self->do_raw_transaction(@queries); +} + +sub create_pk { + my ($self, $table, @cols) = @_; + my $ver = $self->_version; + if ($ver < 7.2) { + return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")"); + } + else { + # ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior + # versions we have to recreate the entire table. + return $self->_recreate_table(); + } +} + +sub drop_pk { +# ----------------------------------------------------------------------------- +# Drop a primary key. Look for the primary key, then call drop_index with it. +# + my ($self, $table) = @_; + + my $sth = $self->prepare("SHOW INDEX FROM $table") or return; + $sth->execute or return; + my $pk_name; + while (my $index = $sth->fetchrow_hashref) { + if ($index->{index_primary}) { + $pk_name = $index->{index_name}; + last; + } + } + + $pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table"); + + $self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name"); +} + +sub ai_insert { + my ($self, $ai) = @_; + return $ai, "NEXTVAL('$self->{name}_seq')"; +} + +sub insert_multiple { +# ----------------------------------------------------------------------------- +# Performs multiple insertions in a single transaction, for much better speed. +# + my $self = shift; + + # ->begin_work and ->commit were not added until 1.20 + return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20; + + $self->{dbh}->begin_work; + my ($cols, $args) = @_; + + my $names = join ",", @$cols, $self->{schema}->{ai} || (); + + my $ret; + my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef; + + my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')'; + my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query); + for (@$args) { + if ($sth->execute(@$_)) { + ++$ret; + } + else { + $self->warn(CANTEXECUTE => $query); + } + } + $self->{dbh}->commit; + $ret; +} + +sub quote { +# ----------------------------------------------------------------------------- +# This subroutines quotes (or not) a value. Postgres can't handle any text +# fields containing null characters, so this has to go beyond the ordinary +# quote() in GT::SQL::Driver by stripping out null characters. +# + my $val = pop; + return 'NULL' if not defined $val; + return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val =~ y/\x00//d; + (values %GT::SQL::Driver::CONN)[0]->quote($val); +} + +package GT::SQL::Driver::PG::sth; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver::sth/; + +sub insert_id { +# ------------------------------------------------------------------- +# Retrieves the current sequence. +# + my $self = shift; + my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i; + $table ||= $self->{name}; + + my $query = "SELECT CURRVAL('${table}_seq')"; + 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; + + return $id; +} + +# ------------------------------------------------------------------------------------------------ # +# DATA TYPE MAPPINGS +# ------------------------------------------------------------------------------------------------ # +package GT::SQL::Driver::PG::Types; +# =============================================================== +use strict; +use GT::SQL::Driver::Types; +use Carp qw/croak/; +use vars qw/@ISA/; +@ISA = 'GT::SQL::Driver::Types'; + +sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') } +sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" } + +# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big) +# caveat to this type, however, is that it requires escaping for any input, and +# unescaping for any output. + +1; diff --git a/site/glist/lib/GT/SQL/Driver/Types.pm b/site/glist/lib/GT/SQL/Driver/Types.pm new file mode 100644 index 0000000..bc7a4bd --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/Types.pm @@ -0,0 +1,191 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::Types +# CVS Info : +# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Implements subroutines for each type to convert into SQL string. +# See GT::SQL::Types for documentation +# +# Supported types are: +# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits +# REAL FLOAT DOUBLE - 32, 32, 64 bits +# DECIMAL - decimal precision +# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc. +# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space +# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type +# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively +# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes +# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons. +# FILE - GT::SQL pseudo-type + +package GT::SQL::Driver::Types; +use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/; +use strict; +use Exporter(); +use GT::Base(); + +*import = \&Exporter::import; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = 'GT::Base'; + +$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/; +@EXPORT_OK = qw/base/; + +sub base { +# ------------------------------------------------------------------ +# Base function takes care of most of the types that don't require +# much special formatting. +# + my ($class, $args, $name, $attribs) = @_; + $attribs ||= []; + my $out = $name; + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + $out; +} + +# Integers. None of the following are supported by Oracle, which can only +# define integer types by the number of digits supported (see +# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by +# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned +# attribute is also passed in). All int types are signed - an 'unsigned' +# column attribute can be used to /suggest/ that the integer type be unsigned - +# but it is only for some databases and/or INT types, and so not guaranteed. +sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int +sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int +sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int +sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int +sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int + +sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above + +# Floating point numbers +sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision) +sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks +sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL + +sub DECIMAL { +# ------------------------------------------------------------------ +# Takes care of DECIMAL's precision. +# + my ($class, $args, $out, $attribs) = @_; + $out ||= 'DECIMAL'; + $attribs ||= []; + + # 'scale' and 'precision' are the proper names, but a prior version used + # the unfortunate 'display' and 'decimal' names, which have no relevant + # meaning in SQL. + my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef; + my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef; + + $scale ||= 0; + $precision ||= 10; + + $out .= "($precision, $scale)"; + + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}); + $args->{not_null} and $out .= ' NOT NULL'; + return $out; +} + +# Dates - just about every database seems to do things differently here. +sub DATE { $_[0]->base($_[1], 'DATE') } +sub DATETIME { $_[0]->base($_[1], 'DATETIME') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') } +sub TIME { $_[0]->base($_[1], 'TIME') } +sub YEAR { $_[0]->base($_[1], 'YEAR') } + +# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255. +# Everything except Oracle handles VARCHAR's - Oracle, having deprecated +# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY' +# attribute to turn this into a "binary" char (meaning, really, +# case-insensitive, not binary) - for everything else, a "binary" argument is +# simply ignored. +sub CHAR { + my ($class, $args, $out) = @_; + # Important the set the size before calling BINARY, because BINARY's + # behaviour is different for sizes <= 255. + $args->{size} = 255 unless $args->{size} and $args->{size} <= 255; + +# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR + $out ||= 'VARCHAR'; + $out .= "($args->{size})"; + + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + return $out; +} +sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') } + +# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to +# provide different types based on the 'size' attribute. +sub TEXT { + my ($class, $attrib) = @_; + $class->base($attrib, 'TEXT') +} + +# .+TEXT is for compatibility with old code, and should be considered +# deprecated. Takes the args hash and the size desired. +sub _OLD_TEXT { + my ($class, $args, $size) = @_; + $args = {$args ? %$args : ()}; + $args->{size} = $size unless $args->{size} and $args->{size} < $size; + $class->TEXT($args); +} +sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) } +sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) } +sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) } +sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) } + +# The BLOB* columns below are heavily deprecated - they're still here just in +# case someone is still using them. Storing binary data inside an SQL row is +# generally a poor idea; a much better approach is to store a pointer to the +# data (such as a filename) in the database, and the actual data in a file. +# +# As such, the default behaviour is to fatal if BLOB's are used - only drivers +# that supported BLOB's prior to protocol v2 should override this. Should a +# binary type be desired in the future, a 'BINARY' pseudo-type is recommended. +sub BLOB { + my ($driver) = $_[0] =~ /([^:]+)$/; + $driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver; + $_[0]->fatal(DRIVERTYPE => $driver => 'BLOB') +} +sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') } +sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') } +sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') } + +# Enums - a non-standard SQL type implemented only by MySQL - the default +# implementation is to implement it as a CHAR (or TEXT if the longest value is +# more than 255 characters - but in that case, are you really sure you want to +# use this type?) +sub ENUM { + my ($class, $args) = @_; + my $max = 0; + @{$args->{'values'}} or return; + for my $val (@{$args->{'values'}}) { + my $len = length $val; + $max = $len if $len > $max; + } + my $meth = $max > 255 ? 'TEXT' : 'CHAR'; + $class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} }); +} + +# File handling +sub FILE { + my ($class, $args) = @_; + $class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} }); +} + +1; diff --git a/site/glist/lib/GT/SQL/Driver/debug.pm b/site/glist/lib/GT/SQL/Driver/debug.pm new file mode 100644 index 0000000..6c223c4 --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/debug.pm @@ -0,0 +1,175 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::debug +# Author: Jason Rhinelander +# CVS Info : +# $Id: debug.pm,v 2.0 2004/08/28 03:51:31 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# GT::SQL::Driver debugging module +# + +package GT::SQL::Driver::debug; +use strict; + +use strict; +use GT::AutoLoader; +use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/; +@ISA = qw(GT::Base); +$QUERY_STACK_SIZE = 100; + +$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB'; +sub last_query { +# ------------------------------------------------------------------- +# Get, or set the last query. +# + my $self = shift; + return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug}); + + @_ > 0 or return $LAST_QUERY || ''; + + $LAST_QUERY = shift; + $LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_); + +# Display stack traces if requested via debug level. + my $stack = ''; + if ($self->{_debug} > 2) { + ($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY); + } + elsif ($self->{_debug} > 1) { + package DB; + my $i = 2; + my $ls = defined $ENV{REQUEST_METHOD} ? '
        ' : "\n"; + my $spc = defined $ENV{REQUEST_METHOD} ? ' ' : ' '; + 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; + $stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!; + } + else { + $stack .= qq!$sub called at $file line $line with no arguments.$ls!; + } + } + } + push @QUERY_STACK, $LAST_QUERY; + push @STACK_TRACE, "
        \n" . $stack . "\n
        \n" if ($self->{_debug} and $stack); + +# Pesistance such as Mod_Perl + @QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK; + @STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE; + + return $LAST_QUERY || ''; +} +END_OF_SUB + +$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB'; +sub js_stack { +# ------------------------------------------------------------------- +# Create a nicely formatted javascript browser that (unfortunately) +# only works in ie, netscape sucks. +# + my ($sp, $title) = @_; + + my $nb = @QUERY_STACK; + my ($stack, $dump_out); + { + package DB; + require GT::Dumper; + my $i = 0; + + while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) { + if (@DB::args) { + $args = "with arguments
           "; + my @args; + for (@DB::args) { + eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference + my $print = $@ ? \$_ : $_; + my $arg = defined $print ? $print : '[undef]'; + + $args .= "$arg, "; + my $dump = GT::Dumper::Dumper($arg); + $dump_out .= qq~ + +Top +
        $dump
        + ~; + $i++; + } + chop $args; chop $args; + } + else { + $args = "with no arguments"; + } + $stack .= qq!
      • $sub called at $file line $line $args.
      • \n!; + } + } + $stack =~ s/\\/\\\\/g; + $stack =~ s/[\n\r]+/\\n/g; + $stack =~ s/'/\\'/g; + $stack =~ s,script,sc'+'ript,g; + + $dump_out =~ s/\\/\\\\/g; + $dump_out =~ s/[\n\r]+/\\n/g; + + $dump_out =~ s/'/\\'/g; + $dump_out =~ s,script,sc'+'ript,g; + + my $var = < +function my$nb () { + msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes'); + msg.document.write('STACK TRACE
          $stack
        $dump_out'); + msg.document.close(); +} +HTML + my $link = qq!$title
        !; + + return $var, $link; +} +END_OF_SUB + +$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB'; +sub quick_quote { +# ------------------------------------------------------------------- +# Quick quote to replace ' with \'. +# + my $str = shift; + defined $str and ($str eq "") and return "''"; + $str =~ s/'/\\'/g; + return $str; +} +END_OF_SUB + +$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB'; +sub replace_placeholders { +# ------------------------------------------------------------------- +# Replace question marks with the actual values +# + my ($self, $query, @args) = @_; + if (@args > 0) { + my @vals = split /('(?:[^']+|''|\\')')/, $query; + VALUE: for my $val (@args) { + SUBSTRING: for my $i (0 .. $#vals) { + next SUBSTRING if $i % 2; + next VALUE if $vals[$i] =~ s/\?/defined $val ? ( $val =~ m,\D, ? "'".quick_quote($val)."'" : quick_quote($val) ) : 'NULL'/e; + } + } + $query = join '', @vals; + } + return $query; +} +END_OF_SUB + +1; diff --git a/site/glist/lib/GT/SQL/Driver/sth.pm b/site/glist/lib/GT/SQL/Driver/sth.pm new file mode 100644 index 0000000..fa1c88e --- /dev/null +++ b/site/glist/lib/GT/SQL/Driver/sth.pm @@ -0,0 +1,293 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::sth +# Author: Jason Rhinelander +# CVS Info : +# $Id: sth.pm,v 2.1 2004/09/30 01:09:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# Generic statement handle wrapper +# + +package GT::SQL::Driver::sth; +use strict; +use GT::Base; +use GT::AutoLoader(NEXT => '_AUTOLOAD'); +require GT::SQL::Driver; +use GT::SQL::Driver::debug; +use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE); + +$DEBUG = 0; +@ISA = qw/GT::SQL::Driver::debug/; +$ERROR_MESSAGE = 'GT::SQL'; + +# Get rid of a 'used only once' warnings +$DBI::errstr if 0; + +sub new { +# -------------------------------------------------------- +# Create a new driver sth. +# + my $this = shift; + my $class = ref $this || $this; + my $opts = {}; + my $self = bless {}, $class; + + if (@_ == 1 and ref $_[0]) { $opts = shift } + elsif (@_ and @_ % 2 == 0) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") } + + $self->{_debug} = $opts->{_debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL'; + + # Drivers can set this to handle name case changing for fetchrow_hashref + $self->{hints} = $opts->{hints} || {}; + + for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) { + $self->{$_} = $opts->{$_} if exists $opts->{$_}; + } + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; +} + +$COMPILE{execute} = __LINE__ . <<'END_OF_SUB'; +sub execute { +# -------------------------------------------------------- +# Execute the query. +# + my $self = shift; + my $do = $self->{do}; + my $rc; + +# Debugging, stack trace is printed if debug >= 2. + 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/
        /\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 (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) { + $meth = "_execute_$meth"; + $rc = $self->$meth(@_) or return; + } + else { + $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); + } + + if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) { + my $elapsed = Time::HiRes::time() - $time; + $self->debug(sprintf("Query execution took: %.6fs", $elapsed)); + } + + $rc; +} +END_OF_SUB + +# Define one generic execute, and alias all the specific _execute_* functions to it +sub _generic_execute { + my $self = shift; + $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); +} +for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) { + $_ = \&_generic_execute; +} + +sub rows { + my $self = shift; + return $self->{_rows} if exists $self->{_rows}; + return $self->{rows} if exists $self->{rows}; + $self->{sth}->rows; +} + +sub fetchrow_arrayref { +# ----------------------------------------------------------------------------- + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_arrayref; + return shift @{$self->{_results}}; +} + +sub fetchrow_array { +# ----------------------------------------------------------------------------- +# When called in scalar context, returns either the first or last row, as per +# DBI, so avoid using in scalar context when fetching more than one row. +# + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_array; + my $arr = shift @{$self->{_results}}; + return $arr ? wantarray ? @$arr : $arr->[0] : (); +} + +# ----------------------------------------------------------------------------- +# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's +# documentation no longer mentions it at all). +*fetchrow = \&fetchrow_array; *fetchrow if 0; + +sub fetchrow_hashref { +# ----------------------------------------------------------------------------- + my $self = shift; + return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results}; + $self->{sth}->fetchrow_hashref; +} + +$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _fetchrow_hashref { +# ----------------------------------------------------------------------------- +# Handles row fetching for driver that can't use the default ->fetchrow_hashref +# due to needing column case mapping ($sth->{hints}->{case_map}), or special +# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit +# handling). +# + my $self = shift; + + my %case_map; # returnedname => ReturnedName, but only for columns that use upper case + if ($self->{hints}->{case_map}) { + if (exists $self->{schema}->{cols}) { + my $cols = $self->{schema}->{cols}; + %case_map = map { lc $_ => $_ } keys %$cols; + } + else { + for my $table (keys %{$self->{schema}}) { + for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) { + $case_map{lc $col} = $col; + } + } + } + } + + if ($self->{_results}) { + my $arr = shift @{$self->{_results}} or return; + + my $i; + my %selected = map { lc $_ => $i++ } @{$self->{_names}}; + my %hash; + + for my $lc_col (keys %selected) { + if (exists $case_map{$lc_col}) { + $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}]; + } + else { + $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}]; + } + } + return \%hash; + } + else { + my $h = $self->{sth}->fetchrow_hashref or return; + for (keys %$h) { + $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_}; + } + return $h; + } +} +END_OF_SUB + +sub fetchall_arrayref { +# --------------------------------------------------------------- + my $self = shift; + return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results}; + + my $opt = shift; + if ($opt and ref $opt eq 'HASH') { + my @ret; + while (my $row = $self->fetchrow_hashref) { + for (keys %$row) { + delete $row->{$_} unless exists $opt->{$_}; + } + push @ret, $row; + } + return \@ret; + } + + my $results = $self->{_results}; + $self->{_results} = []; + return $results; +} + +sub fetchall_list { map @$_, @{shift->fetchall_arrayref} } + +sub fetchall_hashref { +# ----------------------------------------------------------------------------- +# This is very different from DBI's fetchall_hashref - this is actually +# equivelant to DBI's ->fetchall_arrayref({}) +# + my $self = shift; + my @results; + while (my $hash = $self->fetchrow_hashref) { + push @results, $hash; + } + return \@results; +} + +sub row_names { + my $self = shift; + $self->{_names} || $self->{sth}->{NAME}; +} + +$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB'; +sub insert_id { +# ------------------------------------------------------------------- +# Returns the value of the last record inserted. +# + return $_[0]->{sth}->{insertid}; +} +END_OF_SUB + +sub DESTROY { +# ------------------------------------------------------------------- +# Calls finish on the row when it is destroyed. +# + my $self = shift; + $self->debug("OBJECT DESTROYED") if $self->{_debug} > 2; + $self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish"); +} + +sub _AUTOLOAD { +# ------------------------------------------------------------------- +# Autoloads any unknown methods to the DBI::st object. +# + my ($self, @param) = @_; + my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/; + + if (exists $DBI::st::{$attrib}) { + local *code = $DBI::st::{$attrib}; + if (*code{CODE}) { + $self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1; + return code($self->{sth}, @param); + } + } + + $GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD; + goto >::SQL::Driver::debug::AUTOLOAD; +} + +$COMPILE{debug} = __LINE__ . <<'END_OF_SUB'; +sub debug { +# ------------------------------------------------------------------- +# DBI::st has a debug that autoload is catching. +# + my $self = shift; + my $i = 1; + my ( $package, $file, $line, $sub ); + while ( ( $package, $file, $line ) = caller($i++) ) { + last if index( $package, 'GT::SQL' ) != 0; + } + while ( $sub = (caller($i++))[3] ) { + last if index( $sub, 'GT::SQL' ) != 0; + } + return $self->SUPER::debug( "$_[0] from $sub at $file line $line\n" ); +} +END_OF_SUB + +1; diff --git a/site/glist/lib/GT/SQL/Editor.pm b/site/glist/lib/GT/SQL/Editor.pm new file mode 100644 index 0000000..32f3c4f --- /dev/null +++ b/site/glist/lib/GT/SQL/Editor.pm @@ -0,0 +1,1080 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# CVS Info : +# $Id: Editor.pm,v 1.76 2005/04/27 22:53:24 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Editor; +# ================================================================== +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERRORS $error $ERROR_MESSAGE/; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.76 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw(GT::SQL::Base); +$DEBUG = 0; + +sub new { + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)"); + + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). 'table' must be specified in the hash. It needs to be the an object from GT::SQL::Table."); + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + +# We almost always need to be connected. + $self->{table}->connect or return; + return $self; +} + + +################################################################# +##### Editing functions ##### +################################################################# +## +# $obj->add_col($col_name, +# { +# size => 20, +# type => 'int', +# view_size => 20, +# nice_name => "my col", +# regex => 'myregex' +# } +# ); +# ------------------------------------ +# +## +$COMPILE{add_col} = __LINE__ . <<'END_OF_SUB'; +sub add_col { + my ($self, $name, $col) = @_; + + $name and ref $col eq 'HASH' or return $self->fatal(BADARGS => '$obj->add_col(COLUMN_NAME, HASH_REF)'); + my $c = $self->{table}->cols; + + # Check the database instead of the def file so that we don't end up with + # an inability to add a column when the database and def files are out of + # sync. + my $exists = $self->{table}->{driver}->column_exists($self->{table}->name, $name); + $exists and return $self->warn(COLEXISTS => $name); + +# You are not permitted to add a not_null column without a default to a table - +# the default is required for existing columns. You could, if you really want +# it with no default, create it with a default, then alter it to drop the +# default. + return $self->warn(NOTNULLDEFAULT => $name) + if $col->{not_null} and (not defined $col->{default} or $col->{default} eq ''); + +# count file columns + my %fcols_initial = $self->{table}->_file_cols(); + +# handle the search indexes + my $tmp_weight = {}; + $tmp_weight = $self->_get_indexer()->pre_add_column($name, $col) or return if $col->{weight}; + +# get the column definition + my $col_props = $self->{table}->{driver}->column_sql($col); + my $table = $self->{table}->name; + +# Auto add a new position number. + $col->{pos} = keys(%$c) + 1; + +# Add the column into the table's column hash, for checking. +# N.B. - everything below this point _must_ reload the table information (i.e. +# via ->reset or ->reload) upon failure + $c->{$name} = $col; + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + + require GT::SQL::Creator; + GT::SQL::Creator::set_defaults($self, { $name => $col }); + +# Make the changes + $self->{table}->{driver}->add_column($table, $name, $col_props) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + +# Check for file columns + if (not keys %fcols_initial and uc $col->{form_type} eq 'FILE') { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + $self->{table}->_file_cols(1); + } + +# finish off the search indexes + if ($col->{weight}) { + $self->_get_indexer()->post_add_column($name, $col, $tmp_weight) or return; + } + + 1; +} +END_OF_SUB + +## +# $obj->drop_col($col_name); +# --------------------------- +# Drops the column specified by $col_name. +# If the column is referenced returns an error. +# If the column is itself an fk reference, the foreign key is dropped. +# +# $obj->drop_col($col_name, "remove"); +# ------------------------------------- +# Drops column and all fk references to it. +# +## +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { + my $self = shift; + my $name = shift || return $self->fatal(BADARGS => '$obj->drop_col(COLUMN_NAME,[ STRING ])'); + exists $self->{table}->cols->{$name} or return $self->warn(NOCOL => $name); + my $kill = shift; + + my %fcols = $self->{table}->_file_cols(); + my $table = $self->{table}->name; + if ($self->_is_referenced($table, $name)) { + if (defined $kill) { + $self->_remove_references($table, $name); + } + else { + return $self->warn(REFCOL => $name, $table); + } + } + + my @fk_tables = grep exists $self->{table}->{fk}->{$_}->{$name}, keys %{$self->{table}->{fk}}; + if (@fk_tables) { + $self->drop_fk($_, 1); + } + + my $tmp_weight = {}; + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->_get_indexer()->pre_delete_column($name, $self->{table}->cols->{$name}) or return + } + +# Columns + my $old_col = delete $self->{table}->cols->{$name}; + +# Primary key + $self->{table}->pk(grep $_ ne $name, $self->{table}->pk); + +# Foreign keys + while (my ($table, $fk) = each %{$self->{table}->fk}) { + for my $col (keys %$fk) { + if ($col eq $name) { + delete $self->{table}->fk->{$_}->{$col} + } + } + } + +# Indexes and uniques + for my $index (qw/index unique/) { + my $ndx = $self->{table}->$index(); + for (keys %$ndx) { + my @new = grep $_ ne $name, @{$ndx->{$_}}; + if (@new) { + $ndx->{$_} = \@new; + } + else { + delete $ndx->{$_}; + } + } + } + +# Update the positions. + my $cols = $self->{table}->{cols}; + my $i; + for my $col (sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols) { + $cols->{$col}->{pos} = ++$i; + } + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + +# File Handling + if ($fcols{$name}) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->drop_col($name, $fcols{$name}->{file_save_scheme}) or return $self->{table}->reset; + $self->{table}->_file_cols(1); + } + +# Finish off the index table stuff + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->post_delete_column($name, $self->{table}->cols->{$name}, $tmp_weight) + or return $self->{table}->reset; + } + +# Make the changes - actually drop the column + $self->{table}->{driver}->drop_column($table, $name, $old_col) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + + 1; +} +END_OF_SUB + +## +# $obj->alter_col($column_name, \%new_defs); +# ------------------------------------------- +# +$COMPILE{alter_col} = __LINE__ . <<'END_OF_SUB'; +sub alter_col { + my ($self, $col, $defs) = @_; + + ref $defs eq 'HASH' or return $self->fatal(BADARGS => '$obj->alter_col(COLUMN_NAME, HASH_REF)'); + exists $self->{table}->{schema}->{cols}->{$col} or return $self->warn(NOCOL => $col); + + my %fcols = $self->{table}->_file_cols(); + +# Can't change the position, force it to what it was before. + my $orig = $self->{table}->{schema}->{cols}->{$col}; + my $table = $self->{table}->{name}; + +# Set the position, can't be changed. + $defs->{pos} = $orig->{pos}; + +# Check to see if we need to update the SQL. + my $orig_sql = $self->{table}->{driver}->column_sql($orig); + my $new_sql = $self->{table}->{driver}->column_sql($defs); + my $change = $orig_sql ne $new_sql; + +# If we've changed, check the keys. + if ($change) { + return $self->warn(REFCOL => $col, $table) if $self->_is_referenced($table, $col); + return $self->warn(COLREF => $col, $table) if exists $self->{table}->fk->{$col}; + } + +# Check for conflicts + my $old_col = $self->{table}->{schema}->{cols}->{$col}; + $self->{table}->{schema}->{cols}->{$col} = $defs; + $self->{table}->check_schema or return $self->{table}->reset; + +# adding a file column + if (not keys %fcols and $defs->{form_type} and lc $defs->{form_type} eq 'file') { + + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->debug_level($self->{_debug}); + $ftable->install({parent_tablename => $self->{table}->name() }); + } + +# removing a file column + elsif ($fcols{$col} and not ($defs->{form_type} and lc $defs->{form_type} eq 'file')) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->drop_col($col); + } + +# Make the changes + if ($change) { + $self->{table}->{driver}->alter_column($table, $col, $new_sql, $old_col) or return $self->{table}->reset; + } + $self->{mods}->{$table} = $self->{table}; + $self->save_state or return; + +# finish off the file column setup + if ($defs->{form_type} and lc $defs->{form_type} eq 'file') { + $self->{table}->update({ $col => '' }); + $self->{table}->_file_cols(1); + } + + 1; +} +END_OF_SUB + +## +# $obj->add_index($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_index} = __LINE__ . <<'END_OF_SUB'; +sub add_index { + my ($self, $index_name, $columns) = @_; + ref $columns eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_index(INDEX_NAME => ARRAY_REF)'); + +# Do the columns exist? + for (@$columns) { + return $self->warn(NOCOL => $_) unless exists $self->{table}->cols->{$_}; + } + + exists $self->{table}->{schema}->{index}->{$index_name} + and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + $self->{table}->{schema}->{index}->{$index_name} = $columns; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_index($table, $index_name, @$columns) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_index($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB'; +sub drop_index { + my ($self, $index_name) = @_; + $index_name or return $self->fatal(BADARGS => '$obj->drop_index(INDEX_NAME)'); + exists $self->{table}->index->{$index_name} or return $self->warn(NOINDEX => $index_name); + +# Check for conflicts + delete $self->{table}->index->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_unique($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a unique index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_unique} = __LINE__ . <<'END_OF_SUB'; +sub add_unique { + my ($self, $index_name, $indexes) = @_; + + $index_name and ref $indexes eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_unique(INDEX_NAME => ARRAY_REF)'); +# Do the columns exist? + for (@$indexes) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + exists $self->{table}->unique->{$index_name} and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Do the new fields have unique data in them? + my $in = join ", " => @{$indexes}; + my $query = "SELECT $in, COUNT(*) AS hits FROM $table GROUP BY $in HAVING "; + $query .= lc $self->{table}->{connect}->{driver} eq 'mysql' ? 'hits' : 'COUNT(*)'; + $query .= ' > 1'; + $self->debug($query) if $self->{_debug}; + + my $sth = $self->{table}->do($query) or return; + $sth->fetchrow and return $self->warn(NOTUNIQUE => $index_name); + +# Check for conflicts + $self->{table}->unique->{$index_name} = $indexes; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_unique($table, $index_name, @$indexes) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_unique($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_unique} = __LINE__ . <<'END_OF_SUB'; +sub drop_unique { + my ($self, $index_name) = @_; + + $index_name or return $self->fatal(BADARGS => '$obj->drop_unique(INDEX_NAME)'); + exists $self->{table}->unique->{$index_name} or return $self->warn(NOUNIQUE => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + delete $self->{table}->unique->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_pk($field1, $field2, ...); +# ------------------------------------- +# Addes primary keys specified by list. If there is already a primary key it +# drops it and adds all the keys at the same time. If there is no primary +# keys this makes sure the data in the primary keys is unique. +## +$COMPILE{add_pk} = __LINE__ . <<'END_OF_SUB'; +sub add_pk { + my ($self, @fields) = @_; + + @fields or return $self->fatal(BADARGS => '$obj->add_pk(COLUMN1, COLUMN2, ...)'); + for (@fields) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + + my ($table, %add) = $self->{table}->name; + if ($self->{table}->pk) { + $self->{table}->{driver}->drop_pk($table) or return; + %add = map { $_ => 1 } @{delete $self->{table}->{schema}->{pk}}; + } + +# Check for conflicts + for (@fields) { $add{$_} = 1 } + $self->{table}->{schema}->{pk} = [keys %add]; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_pk($table, keys %add) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_pk; +# -------------- +# Drops the current primary key. +## +$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB'; +sub drop_pk { + my $self = shift; + $self->{table}->pk or return $self->warn('NOPK'); + +# Check for conflicts + $self->{table}->{schema}->{pk} = []; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_pk($table) or return $self->{table}->reset; + 1; +} +END_OF_SUB + +## +# $obj->add_fk( RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +$COMPILE{add_fk} = __LINE__ . <<'END_OF_SUB'; +sub add_fk { + my $self = shift; + $self->{table}->fk(@_) or return; + 1; +} +END_OF_SUB + +## +# $obj->drop_fk(RELATION_NAME [, SKIPSAVE]); +# --------------------------------------------- +# Drops the foreign key relation for a given relation. If a second parameter +# is passed, and true, the state of the current table will not be saved (any +# other changed tables are, however). +## +$COMPILE{drop_fk} = __LINE__ . <<'END_OF_SUB'; +sub drop_fk { + my ($self, $tbl, $nosave) = @_; + my $table = $self->{connect}->{PREFIX} . $tbl; + delete $self->{table}->{schema}->{fk}->{$table} + or return $self->warn(FKNOEXISTS => $tbl, $self->{table}->{name}); + my $remote = $self->new_table($table); + my $rfk = $remote->fk_tables || []; + $remote->fk_tables([grep $_ ne $self->{table}->{name}, @$rfk]); + $remote->save_state; + $self->{table}->save_state unless $nosave; +} +END_OF_SUB + +## +# $obj->add_tree(ARGS); +# --------------------- +# Create a tree table for the current table. +# 'ARGS' is a hash or hash reference consisting of the following: +# father => 'father_id_column', +# root => 'root_id_column', +# depth => 'depth_column' +# where 'father_id_column', 'root_id_column', and 'depth_column' are the names +# of the columns you will use for keeping track of the father record, root +# record, and the depth from the root record, respectively. All of these +# columns should already exist - an error will occur if they do not. +# +# Any other arguments passed in will be passed straight through to +# GT::SQL::Tree->create +## +$COMPILE{add_tree} = __LINE__ . <<'END_OF_SUB'; +sub add_tree { + my $self = shift; + + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(HASH or HASH REF)'); + + return $self->warn(TREEEXISTS => $self->{table}->{name}) if $self->{table}->{schema}->{tree} and ($input->{force} || 'force') eq 'check'; + + $input->{father} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., father => \'father_col\', ...)'); + $input->{root} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., depth => \'depth_col\', ...)'); + + require GT::SQL::Tree; + GT::SQL::Tree->create(debug => $self->{_debug}, %$input, table => $self->{table}); +} +END_OF_SUB + +$COMPILE{drop_tree} = __LINE__ . <<'END_OF_SUB'; +sub drop_tree { + my $self = shift; + my $tree = $self->{table}->tree or return; + $tree->destroy; +} +END_OF_SUB + +$COMPILE{load_data} = __LINE__ . <<'END_OF_SUB'; +sub load_data { +# --------------------------------------------------------------- +# imports the contents of a file with validation. +# + my ($self, $file, $options) = @_; + -f $file and -r _ or return $self->fatal(FILENOEXISTS => $file); + $self->{table}->connect or return; + + my $delim = $options->{delim} || '|'; + my @cols = ref $options->{cols} ? @{$options->{cols}} : @{$self->{table}->ordered_columns}; + + local *FILE; + open FILE, $file or return $self->warn(CANTOPEN => $file, "$!"); + while () { + chomp; + my $i = 0; + my %fields = map { $cols[$i++] => $_ } split /(?{table}->insert(\%fields, 1) or print "Line $. skipped - validation failed:\n$GT::SQL::error\n\n"; + } + close FILE; + 1; +} +END_OF_SUB + +$COMPILE{export_data} = __LINE__ . <<'END_OF_SUB'; +sub export_data { +# --------------------------------------------------------------- +# Dumps the contents of a table to a file. +# + my $self = shift; + my $opt = shift; + ref $opt eq 'HASH' or return $self->fatal(BADARGS => '$obj->export_data(HASHREF)'); + + my $order = $opt->{order}; + my $delim = $opt->{delim} || '|'; + my $file = $opt->{file} || undef; + my $header = $opt->{header} || undef; + my $table = $self->{table}->name; + + my @order = $order + ? ref $order eq 'ARRAY' ? @$order : $order + : $self->{table}->ordered_columns; + + my ($offset, $limit) = (0, 1000); + + local *FILE; + if ($file) { + open FILE, "> $file" or return $self->warn(CANTOPEN => $file, "$!"); + } + while () { + $self->{table}->select_options("LIMIT $limit OFFSET " . ($offset++ * $limit)); + my $sth = $self->{table}->select(\@order); + + if ($header) { + print FILE join($delim, @order), "\n"; + $header = undef; + } + my $count = 0; + while (my $arr = $sth->fetchrow_arrayref) { + ++$count; + for (@$arr) { + y/\r//d; + s/\Q$delim\E/``/g; + s/\n/~~/g; + } + my $joined = join $delim, @$arr; + $file + ? print FILE $joined, "\n" + : print $joined, "\n"; + } + last unless $count; + } + 1; +} +END_OF_SUB + +## +# $obj->drop_search_driver +# ----------------- +# Drops current search driver +## +$COMPILE{drop_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub drop_search_driver { + my $self = shift; + + require GT::SQL::Search; + if ($self->{table}->search_driver) { + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}) or return; + $indexer->drop_search_driver or return; + } + $self->{table}->search_driver('NONINDEXED'); + $self->{table}->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{add_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub add_search_driver { + my $self = shift; + my $olddriver = $self->{table}->search_driver(); + my $newdriver = shift or return; + + require GT::SQL::Search; + +# check and see if driver is ok + GT::SQL::Search->driver_ok($newdriver, { table => $self->{table} }) or return; + +# load the driver + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}, driver => $newdriver) or return; + $indexer->add_search_driver or return; + + $self->{table}->search_driver($newdriver); + $self->{table}->save_state or return; + 1; +} +END_OF_SUB + +## +# $obj->change_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{change_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub change_search_driver { + my $self = shift; + my $newdriver = uc shift or return; + my $driver = $self->{table}->search_driver; + $driver eq $newdriver and return $self->warn(SAMEDRIVER => $driver); + + $self->drop_search_driver() or return; + $self->add_search_driver($newdriver) or return; + + 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + my $rm_fk = lc(shift or '') eq 'remove'; + my $table = $self->{table}->name; + my $tmp = $self->{table}->fk_tables() || []; + @$tmp and !$rm_fk and return $self->warn(TABLEREFD => $table); + + my $tmp_weights = {}; + if ($self->_uses_weights) { + $tmp_weights = $self->_get_indexer->pre_drop_table() or return + } + + $self->{table}->{driver}->drop_table($table) or return; + + delete $GT::SQL::OBJ_CACHE{"TABLE\0$table\0$self->{connect}->{def_path}"}; + +# If this table has a tree, drop it: + $self->drop_tree if $self->{table}->{schema}->{tree}; + + unlink "$self->{connect}->{def_path}/$table.def"; + + for (keys %{$self->{table}->{schema}->{fk}}) { + next if $_ eq $table; + my $t = $self->new_table($_); + $t->{schema}->{fk_tables} = [grep $_ ne $table, @{$t->{schema}->{fk_tables}}]; + $t->save_state(); + } + + $self->_file_drop_tables(); + $self->_uses_weights and ($self->_get_indexer->post_drop_table($tmp_weights) or return); + $rm_fk and $self->_drop_related_fk_entries($table); + + 1; +} +END_OF_SUB + +$COMPILE{_file_drop_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_drop_tables { + my $self = shift; + if ( $self->{table}->_file_cols() ) { + require GT::SQL::File; + GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} })->drop_table(); + } +} +END_OF_SUB + +$COMPILE{_drop_related_fk_entries} = __LINE__ . <<'END_OF_SUB'; +sub _drop_related_fk_entries { + my $self = shift; + my $table_name = shift or return; + + my $fk = $self->{table}->fk() or return; + my $prefix = $self->{connect}->{PREFIX}; + for my $related_name ( keys %{$fk} ) { + my $table = $self->{table}->new_table($related_name); + my $fk_tables = $table->fk_tables() or next; + $fk_tables = [ grep { $_ ne $table_name } @{$fk_tables} ]; + $table->fk_tables( $fk_tables ); + $table->save_state(); + } + + 1; +} +END_OF_SUB + +########################################################################### +##### Private Functions ##### +########################################################################### + +$COMPILE{_is_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _is_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $fk = $self->new_table($table)->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + return 1; + } + } + } + } + 0; +} +END_OF_SUB + +$COMPILE{_remove_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _remove_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $new_table = $self->{mods}->{$table} || $self->new_table($table); + my $fk = $new_table->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + delete $fk->{$mytable}->{$key}; + $self->{mods}->{$table} ||= $new_table; + } + if (not keys %{$fk->{$mytable}}) { + delete $fk->{$mytable}; + $self->{mods}->{$table} ||= $new_table; + } + } + } + } + 1; +} +END_OF_SUB + +$COMPILE{_remove_references} = __LINE__ . <<'END_OF_SUB'; +sub _remove_references { + my ($self, $mytable, $mycol) = @_; + for my $table (keys %{$self->{table}->fk}) { + if ($self->{table}->fk->{$table}->{$mycol}) { + delete $self->{table}->fk->{$table}->{$mycol}; + } + next if keys %{$self->{table}->fk->{$table}}; + my $t = $self->{mods}->{$table} || $self->new_table($table); + $t->{schema}->{fk_table} = [grep $_ ne $mytable, @{$t->fk_tables}]; + $self->{mods}->{$table} = $t; + } + 1; +} +END_OF_SUB + +sub save_state { + my $self = shift; + for my $table (keys %{$self->{mods}}) { + my $new_table = $self->{mods}->{$table}; + $new_table->save_state or return; + delete $self->{mods}->{$new_table}; + } + 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Editor - an interface to modify an SQL table. + +=head1 SYNOPSIS + + my $editor = $DB->editor('Table'); + $editor->add_col(Foo => { size => 20, type => 'int' }); + $editor->export_data('/tmp/foo.txt'); + +=head1 DESCRIPTION + +GT::SQL::Editor is an easy way to do a lot of table maintenance +functions like: + +* Adding columns +* Dropping columns +* Changing columns +* Altering keys +* Importing data +* Dropping data + +To get an editor object, you simply call C from a +GT::SQL object, and specify the tablename you want to edit: + + $editor = $db->editor('TableName'); + +Note: You can not use Editor with relations, only tables. + +=head2 add_col + +This method allows you to add a column to the current table. +All attributes for the column are passed in a single hash. + + $editor->add_col($col_name, + { + size => 20, + type => 'int', + view_size => 20, + nice_name => "my col", + regex => 'myregex' + } + ); + +The same rules apply to this method that apply when you +define a column for creating a table. You must specify the +type. + +=head2 drop_col + +This method drops a column from the current table. Checks +are made to ensure the column is not linked to by a foreign +key relation. + + $editor->drop_col($col_name); + +-or- + + $editor->drop_col($col_name, "remove"); + +If you just specify the column name C will check if +the column is referenced in a foreign key relation. If it +is C will return undef and set the error message in +$GT::SQL::error. If it is not the column will be dropped. + +If you specify "remove" C will remove all foreign +key relations that point to the specified column. + +If the specified column is itself a foreign key relation, the relation will be +dropped. + +=head2 alter_col + +This allows you to make changes to a columns type, null status, +etc.. + + $editor->alter_col($column_name, + { + size => 20, + type => 'int' + }); + +The first argument is the column name the second is the definitions. +The column definitions are exactly the same as the column +definitions from the create. The type must be specified. + +You can not add attributes to the column in this way. +You must specify the original definitions along with the +changes you need to make. + +=head2 add_unique + +This allows you to add a unique index to the current table. +If the name of the unique index is the same as another +index you C will return undef and set the error +in $GT::SQL::error. + + $editor->add_unique($index_name => [ $field1, $field2 .. ]); + +The name of the new index is the first argument. The second argument +is an array reference containing the columns that will be indexed. +The order of the columns are maintained for the unique index. +If you specify an index that has data in it that is not unique +(yes we do a select on the database) C will return +an error and set the error in $GT::SQL::error. + +=head2 drop_unique + +This method allows you to drop a unique index for the current +table. If the unique index does not exist C will +return undef and set the error in $GT::SQL::error. C +will also check to make sure dropping the unique index will not +cause problems for the database structure. If dropping the unique +index will cause a problem C will return undef and set +the error in $GT::SQL::error. + + $editor->drop_unique($index_name); + +$index_name should be the name of the unique index to drop. + +=head2 add_index + +This takes the same arguments as C and return the same thing. +The only difference is C has no reason to check the content of +the current table because indexes are not unique. unique indexes are :) + + $editor->add_index($index_name => [ $field1, $field2 .. ]); + +=head2 drop_index + +This method drops the specified index from the current table. +C will check to make sure no problems are caused from +dropping the index. If there are C will return undef +and set the error in $GT::SQL::error. + + $editor->drop_index($index_name); + +$index_name should be the name of the index to drop. + +=head2 add_pk + +This method allows you to add a primary key to the current +database. + + $editor->add_pk($field1, $field2, ...); + +If there is already a primary key in the database C +will drop the key and add the this new one. The table +will be check to make sure this change does not create problems +for the table. I problem is auto increment not being the primary +key anymore. If there is a problem this function returns undef +and stores the error in $GT::SQL::error. + +=head2 drop_pk + +This method drops the current primary key. If there is no primary +key to drop it returns undef and sets the error in $GT::SQL::error. + + $editor->drop_pk; + +If dropping the primary key will cause problems for the database +this method will return undef and set the error in $GT::SQL::error. + +=head2 add_fk + +This method allows you to add foreign key relations to the current +table. + + $editor->add_fk($RELATION_NAME, { $SOURCE_FIELD_1 => $TARGET_FIELD }); + +You can not link your foreign key to tables that do not exist. Also the +columns types and lengths for the two columns must be the same. +Circularity is not allowed either. That is a set of foreign keys can not +end up pointing back at the same table they started at. All of these things +are checked when this is added. If anything does not match this method returns +undef and sets the error in $GT::SQL::error. + +=head2 drop_fk + +This method drops the specified foreign key relation. + + $editor->drop_fk($table); + +$table should be the name of the foreign table the foreign +key points to. + +=head2 drop_table + +This method drops the current table. If there are any foreign keys +pointing to this table this method will fail and return undef. The error +will be set in $GT::SQL::error. + + $editor->drop_table; + +-or- + + $editor->drop_table("remove"); + +If the first argument to this method is remove it will remove all +the foreign key relations that point to this table. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Editor.pm,v 1.76 2005/04/27 22:53:24 brewt Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/File.pm b/site/glist/lib/GT/SQL/File.pm new file mode 100644 index 0000000..7712afd --- /dev/null +++ b/site/glist/lib/GT/SQL/File.pm @@ -0,0 +1,1079 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::File +# Author : Aki Mimoto +# CVS Info : +# $Id: File.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# + +package GT::SQL::File; + +use strict; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; +use GT::Base; +use vars qw/@ISA $ERRORS $ATTRIBS $LOG $ERROR_MESSAGE $PERMIT_REFS $DEBUG/; +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$ATTRIBS = { + db => undef, + connect => undef, + def_path => undef, + table_name => '', + table_object => undef, + parent_table => undef, + parent_table_name => undef, + file_save_in => '', + file_log_path => '', + file_name => '', + file_path => '', + file_fpath => '', + + File_Name => '', + ID => '', + ForeignColName => '', + ForeignColKey => '', + File_Name => '', + File_Directory => '', + File_MimeType => '', + File_Size => '', + File_RelativePath => '', + File_Binary => undef, + File_URL => '', + + file_handle => undef, +}; + +# this allows calls to the individual attribs through GT::SQL::File::Fh method +$PERMIT_REFS = { map { $_ => 1 } keys %$ATTRIBS }; +$LOG = { + ADDED => q~Added file %s to %s~, + REPLACE => q~Replaced file %s to %s~, + REMOVED => q~Deleted file %s~, + CREATEDDIR => q~Created directory %s~ +}; + +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + FILE_PARENTTBL => q~Cannot load parent table! (%s)~, + FILE_FILETBL => q~Cannot load file table! (%s)~, + FILE_NOGLOBREF => q~Need a file glob reference in (%s)~, + FILE_FILETOOBIG => q~File %s size: %i exceeds max file size value: %i~, + FILE_NOOPEN => q~Problems opening %s for writing: %s~, + FILE_NOBINMODE => q~Could not set %s to binmode: %s~, + FILE_NOCLOSE => q~Had problems closing file %s: %s~, + FILE_NOFILE => q~Could not find file related by ForeignColName => %s, ForeignColKey => %s: %s~, + FILE_FDELETE => q~Problems deleting file %s: %s~, + FILE_NOUNLINK => q~Could not unlink file %s: %s~, + FILE_PKREQ => q~Primary Key required~, + FILE_PKSINGLE => q~Composite Primary Keys not supported~, + FILE_DBDELETE => q~Problems deleting record: %s~, + FILE_DBDELETEALL => q~Problems deleting all records~, + FILE_DBSELECT => q~Problems selecting %s~, + FILE_NOREC => q~Could not find file record~, + FILE_DBDROP => q~Could not drop table %s: %s~, + FILE_DBEDITOR => q~Could not get editor object for table %s: %s~, + FILE_DBUPDATE => q~Problems updating record: %s~, + FILE_DBADD => q~Problems adding record: %s~, + FILE_ILLEGALCHAR => q~Illegal character found in %s~, + FILE_NOOPEN => q~Could not open %s because %s~, + FILE_NOWRITE => q~Could not write data into %s because %s~, + FILE_MKDIRFAIL => q~Couldn't create directory %s, because %s~, + FILE_UNKNOWNREF => q~Reference call '%s' does not refer to a method in GT::SQL::File or an allowed attribute.~ +}; + +@$GT::SQL::ERRORS{keys %$ERRORS} = values %$ERRORS; + +use constant ENCODE => 1; + +$COMPILE{rescan} = __LINE__ . <<'END_OF_SUB'; +sub rescan { +#------------------------------------------------------------------------------- +# $obj->rescan(); +#---------- +# Rebuilds the database and attempts to ensure that database records are +# correct. This does not update the parent tables +# + my ( $self ) = @_; + + my %errs = (); + my %mods = (); + my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error); + my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error); + my %fcols = $ptbl->_file_cols(); + my $sth = $tbl->select() or return $self->error('FILE_DBSELECT', 'WARN', $GT::SQL::error); + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}); + +# does this file still exist? + if ( ! -e $fpath ) { + $errs{$href->{ID}} = "NOFILE"; + $self->error( 'FILE_NOFILE', 'WARN', $href->{ForeignColName}, $href->{ForeignColKey}, "FILENOEXIST"); + $tbl->delete({ ForeignColName => $href->{ForeignColName}, ForeignColKey => $href->{ForeignColKey} }); + } + +# is it still the same file size? + elsif ( -s _ != $href->{File_Size}) { + $mods{$href->{ID}} = "NEWSIZE"; + $href->{File_Size} = -s _; + $tbl->modify($href) or $errs{$href->{ID}} = "CANTMODIFY"; + } + } + + return \%errs, \%mods; +} +END_OF_SUB + +$COMPILE{log} = __LINE__ . <<'END_OF_SUB'; +sub log { +#------------------------------------------------------------------------------- +# $obj->log( $code, LIST ); +#---------- +# puts a log message into the logs file if the path has been set +# + my $self = shift; + my $code = shift; + my $logpath = $self->{file_log_path} or return; + + $self->_check_file_chars( $logpath ) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $logpath ); + CORE::open( LOG, ">>$logpath" ); + print LOG sprintf($LOG->{$code}, @_); + close( LOG ); +} +END_OF_SUB + +$COMPILE{add_file} = __LINE__ . <<'END_OF_SUB'; +sub add_file { +#------------------------------------------------------------------------------- +# $obj->addfile( $new_record, $new_record_id ) +#---------- +# puts a file away into the database +# + my ($self, $rec, $recid ) = @_; + return $self->replace_file( $rec, $recid ); +} +END_OF_SUB + +$COMPILE{replace_file} = __LINE__ . <<'END_OF_SUB'; +sub replace_file { +# -------------------------------------------------------------------------------------- +# $obj->replace_file( $new_record, $new_record_id ) +#---------- +# puts a file away into the database, if a file already exists in place, delete it +# + my ($self, $rec, $recid ) = @_; + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $fcols = { $ptable->_file_cols() }; + my $ftable = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + + foreach my $col_name ( keys %$fcols ) { + +# basic tests + my $col = $fcols->{$col_name}; + my $ref = ref $rec->{$col_name}; + my $fh = ( ( $ref and $ref !~ /SCALAR|ARRAY|HASH/ ) ? $rec->{$col_name} : $self->get_fh( $col_name, $rec ) ) or next; + $col->{file_max_size} and ( ( -s $fh ) <= $col->{file_max_size} or return $self->error( 'FILE_FILETOOBIG', 'WARN', "$fh", -s $fh, $col->{file_max_size} ) ); + +# now, delete the previous entry + if ( $ftable->count({ ForeignColName => $col_name, ForeignColKey => $recid }) ) { + ref $fh or $rec->{$col_name."_del"} and $self->delete_file( $col_name, $recid, $col->{file_save_scheme} ); + } + +# find out if we're simply going to skip the action here + not ref $fh and not $fh eq 'delete' and next; + +# get basic information setup + my @paths = split m.(/|\\)., "$fh"; #/\ + my $fname = $rec->{$col_name."_filename"} || pop @paths; + my $fdir = $col->{file_save_in}; + +# now that we have saved the information, add the record to the database + my $new_rec = $self->_file_getstats( $fname, $fdir, $col->{file_save_url}, -s $fh ); + + $new_rec->{ForeignColName} = $col_name; + $new_rec->{ForeignColKey} = $recid; + my $fid = $ftable->add($new_rec) or return $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ); + +# now try to save + my $fpath = $self->_file_full_path( $fname, $fdir, $fid, $col_name, $col->{file_save_scheme}, ENCODE ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + { local $/; print F <$fh> or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ); } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + + $self->log( 'ADDED', $fname, $fdir ); + + } + + return 1; +} +END_OF_SUB + +$COMPILE{delete_file} = __LINE__ . <<'END_OF_SUB'; +sub delete_file { +# -------------------------------------------------------------------------------------- +# $obj->delete_file( $col_name, $recid, $save_scheme ); +#---------- +# deletes the files and records associated +# function that is usually used internally +# + my ( $self, $col_name, $recid, $save_scheme ) = @_; + +# get the path to the file + my $tbl = $self->_tbl(); + my $rec = $tbl->get({ ForeignColName => $col_name, ForeignColKey => $recid }) or return $self->error( 'FILE_NOFILE', 'WARN', $col_name, $recid, $GT::SQL::error ); + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col_name, + $save_scheme, + ); + +# nuke the database record + $tbl->delete({ ForeignColName => $col_name, ForeignColKey => $recid }) or return $self->error( 'FILE_FDELETE', 'WARN', $rec->{File_Name}, $GT::SQL::error); + +# nuke the file + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + $self->log( 'REMOVED', $rec->{File_Name} ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { +# -------------------------------------------------------------------------------------- +# $obj->delete_records( $condition ) +#---------- +# deletes all records addressed by the condition. +# usually used in conjunction with a delete of the parent table elements. +# BUT must be called before parent table is deleted +# + my ( $self, $where ) = @_; + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my @pk = $ptbl->pk() or return $self->error( 'FILE_PKREQ', 'WARN' ); + @pk == 1 or return $self->error( 'FILE_PKSINGLE', 'WARN' ); + my $pk = $pk[0]; + my %fcols = $ptbl->_file_cols(); + my $sth = $ptbl->select( [ $pk ], $where ); + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + + while ( my $raref = $sth->fetchrow_arrayref() ) { + my $col_key = $raref->[0]; + my $fsth = $tbl->select( [qw( ID ForeignColName File_Directory File_Name )], { ForeignColKey => $col_key }); + + while ( my $aref = $fsth->fetchrow_arrayref() ) { + my $fpath = $self->_file_full_path( map( {$aref->[$_]} qw( 3 2 0 1 ) ), $fcols{$aref->[1]}->{file_save_scheme} ) or next; + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ), next; + $self->log( 'REMOVED', $aref->[3] ); + + } + + $tbl->delete({ ForeignColKey => $col_key }) or $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + } + +} +END_OF_SUB + +$COMPILE{update_records} = __LINE__ . <<'END_OF_SUB'; +sub update_records { +# -------------------------------------------------------------------------------------- +# $obj->update_records( $set, $condition ); +#---------- +# treated like $tbl->modify. will update all records with new files if required. +# if multiple records are to receive copies of the file, multiple copies of the files +# will be created on disk +# + my $self = shift; + my $set = shift or return $self->error ('BADARGS', 'FATAL', "First argument to update_records must be \$set of what was set."); + my $cond = shift or return $self->error ('BADARGS', 'FATAL', "Condition object must be passed as second argument."); + +# init variables + my $ptbl = $self->_parent_tbl(); + my @pk = $ptbl->pk() or return $self->error( 'FILE_PKREQ', 'WARN' ); + @pk == 1 or return $self->error( 'FILE_PKSINGLE', 'WARN' ); + my %fcols = $ptbl->_file_cols() or return $self->error ('BADARGS', 'FATAL', "update_records was called when there are no file columns, possibly corrupt def file."); + my %flocs = (); + +# find out which columns need to be updated + my @rcols = grep( defined ( $set->{$_} || $set->{$_."_del"} ), keys %fcols ) or return 1; # Nothing to do. + my $tbl = $self->_tbl(); + +# find out what records need to be updated + my $sth = $ptbl->select( [ $pk[0] ], $cond ); + while ( my $aref = $sth->fetchrow_arrayref() ) { + my $col_key = $aref->[0]; + +# now for each of the record's columns do what has to be done... delete, update, nothing? + foreach my $col ( @rcols ) { + + my $tmp = $flocs{$col} ||= {}; + my $fh = $tmp->{name} ? do { CORE::open SOURCE, "<$tmp->{path}"; \*SOURCE } : $self->get_fh( $col, $set ); + + ( not ref $fh and not $set->{$col."_del"} ) and ( $self->error( 'FILE_NOGLOBREF', 'WARN', $col ), next ); + + + my $fname = $tmp->{name} ||= ( $set->{$col."_filename"} || $self->get_filename( "$fh" ) ); + my $fdir = $tmp->{dir} ||= $fcols{$col}->{file_save_in}; + + my $rec; + if ( not $rec = $tbl->get({ ForeignColName => $col, ForeignColKey => $col_key }) ) { + $rec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + $rec->{ForeignColKey} = $col_key; + $rec->{ForeignColName} = $col; + $rec->{ID} = $tbl->add( $rec ) or $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ),next; + } + else { + + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + if ( ref $fh ) { + my $trec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + for ( keys %$trec ) { $rec->{$_} = $trec->{$_} }; + $tbl->modify($rec) or ( $self->error( 'FILE_DBUPDATE', 'WARN', $GT::SQL::error ),next ); + } + elsif ( $set->{$col."_del"} ) { + $tbl->delete({ ForeignColName => $col, ForeignColKey => $col_key }) or $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + next; + }; + + } + + my $fpath = $tmp->{path} ||= $self->_file_full_path( + ( $rec->{File_Name} = $tmp->{name} ), + $fdir, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + { local $/; print F <$fh> or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ) } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + close $fh; + + $self->log( 'ADDED', $rec->{File_Name}, $fdir ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_record} = __LINE__ . <<'END_OF_SUB'; +sub _delete_record { +# -------------------------------------------------------------------------------------- +# $obj->_delete_record( $columnname, $columnkey, $save_scheme ); +#---------- +# takes the parameters that identify a record in the _File uniquely and deletes +# record and file +# + my $self = shift; + my $col_name = shift or return; + my $col_key = shift or return; + my $save_scheme = shift or return;; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + +# get the column information + my $href = $tbl->get({ + ForeignColName => $col_name, + ForeignColKey => $col_key, + }) or return $self->error( 'FILE_NOREC', 'WARN', $GT::SQL::error ); + + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols() or return; + +# get the filename of the record + my $fname = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $col_key, $col_name, $save_scheme ); + +# delete the file now that we have the file path + unlink $fname or return $self->error( 'FILE_NOUNLINK', 'WARN', $fname, "$!" ); + +# nuke the record + $tbl->delete({ + ForeignColName => $col_name, + ForeignColKey => $col_key, + }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# -------------------------------------------------------------------------------------- +# $obj->delete_call( $col_name ) +#---------- +# takes the name of a file column from the parent and deletes all files and records +# associated +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols(); + + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete_all() or return $self->error( 'FILE_DBDELETEALL', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { +# -------------------------------------------------------------------------------------- +# $obj->drop_col( $name ) +# ----- +# $name : name of column to drop +# ----- +# Will remove all files associated to that particular column. If there are no more +# file columns, as it is no longer required, drop the file table . +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return 1; + my $ptbl = $self->_parent_tbl(); + my %fcols = $ptbl->_file_cols(); + my $save_scheme = shift || $fcols{$name}->{file_save_scheme}; + my $sth = $tbl->select({ ForeignColName => $name }) or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $name, $save_scheme ); + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete({ ForeignColName => $name }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + delete $fcols{$name}; + +# if there are no file based columns left, we can drop the file support table + require GT::SQL::Editor; + if ( not %fcols ) { + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table('remove') or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + } + + return 1; +} +END_OF_SUB + +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { +# -------------------------------------------------------------------------------------- +# $obj->drop_table(); +#---------- +# deletes all files in the table and drops the table (including records) +# + my $self = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $self->_parent_tbl()->_file_cols() or return; + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $save_scheme = $fcols{$href->{ForeignColName}}->{file_save_scheme}; + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $save_scheme ); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + require GT::SQL::Editor; + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table() or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{open} = __LINE__ . <<'END_OF_SUB'; +sub open { +# -------------------------------------------------------------------------------------- +# $obj->open( $path_to_file ); +#---------- +# creates a GT::SQL::File::Fh Filehandle object +# + my $self = shift; + return GT::SQL::File::Fh->new(@_); +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# -------------------------------------------------------------------------------------- +# $obj->file_info( $columnname, $primarykeyvalue ); +#---------- +# returns a filehandle to file stored in database. if there is none, returns +# undef with an error set in $GT::SQL::error +# + my $self = shift; + my $name = shift or return; + my $key = shift or return; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptable->_file_cols(); + my $file_rec = $tbl->get({ ForeignColName => $name , ForeignColKey => $key }) or return $self->error( 'FILE_NOFILE', 'WARN', $name, $key, $GT::SQL::error ); + + my $fpath = $self->_file_full_path( + $file_rec->{File_Name}, + $file_rec->{File_Directory}, + $file_rec->{ID}, + $name, + $fcols{$name}->{file_save_scheme}, + 1 + ); + my $relpath = $self->_file_full_path( + $file_rec->{File_Name}, + '', + $file_rec->{ID}, + $name, + $fcols{$name}->{file_save_scheme}, + 1 + ); + $file_rec->{File_RelativePath} = $relpath; + $file_rec->{File_URL} = $file_rec->{File_URL} . $relpath; + + return GT::SQL::File::Fh->new( $fpath, $file_rec ); +} +END_OF_SUB + +$COMPILE{_file_full_path} = __LINE__ . <<'END_OF_SUB'; +sub _file_full_path { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_full_path( $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) +#---------- +# $fname : filename +# $fdir : directory of file +# $fid : id of the parent record +# $save_scheme : hashed or simple +# $enc : if we should encode the filepath or try to decode it +#---------- +# returns the full path to the storeage location and name of the file the record +# points at +# the filename is typically encoded for the sake of special characters +# + my ( $self, $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) = @_; + + $save_scheme ||= 'HASHED'; + +# build paths to which we'll save all the information + $fdir = $self->_filepath_munge( $fdir, $fid, $save_scheme ); + $fname = $self->_filename_munge( $fname, $fid, $fcol, $save_scheme, $enc ); + my $fpath = "$fdir/$fname"; + + return $fpath; +} +END_OF_SUB + +$COMPILE{_file_getstats} = __LINE__ . <<'END_OF_SUB'; +sub _file_getstats { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_getstats( $fname, $fpath, $fsize ); +#---------- +# starts to build a record to be used for inserts/modifies into +# the _File database table +# + my ( $self, $fname, $fpath, $furl, $fsize ) = @_; + require GT::MIMETypes; + my $rec = { + File_Name => $fname || '', + File_Directory => $fpath || '', + File_MimeType => GT::MIMETypes->guess_type($fname), + File_Size => defined $fsize ? $fsize : '', + File_URL => $furl || '' + }; + + return $rec; +} +END_OF_SUB + +$COMPILE{_filename_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filename_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filename_munge( $fname, $fid, $fcol, $method, $enc ) +#---------- +# should only be called internally. changes the filename so it can be saved without +# name conflicts +# + my ( $self, $fname, $fid, $fcol, $method, $enc ) = @_; + + $fname = "$fid-$fname"; + + require GT::CGI; + $fname = $enc ? GT::CGI->escape( $fname ) : GT::CGI->unescape( $fname ); + + return $fname; +} +END_OF_SUB + +$COMPILE{_filepath_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filepath_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filepath_munge(); +#---------- +# sets up the path directory where the file should be saved. +# + my ( $self, $fpath, $fid, $method ) = @_; + + if ( $method =~ /hashed/i ) { + my $fletter = ( reverse split //, $fid )[0]; + my $nfpath = "$fpath/$fletter"; + if ( $fpath ) { + -e $nfpath or mkdir $nfpath, 0777 or return warn "Couldn't make directory $nfpath because $!"; + } + $fpath = $nfpath; + } + + return $fpath; +} +END_OF_SUB + +$COMPILE{_check_file_chars} = __LINE__ . <<'END_OF_SUB'; +sub _check_file_chars { +#------------------------------------------------------------------------------- +# $obj->_check_file_chars( $fpath ); +#---------- +# return true if file path is ok +# + return $_[1] =~ /^[\w\/\\\-\.\:%]+$/; +} +END_OF_SUB + +$COMPILE{install} = __LINE__ . <<'END_OF_SUB'; +sub install { +#------------------------------------------------------------------------------- +# $obj->install( $options ); +#---------- +# creates the associate file parameter storage table +# $tops is passed into the creation option database +# + my ( $self, $opts ) = @_; + +# get the name of the table + my $ptbl_name = $opts->{parent_tablename} || $self->{parent_tablename}; + my $tb_name = $ptbl_name . '_Files'; + +# create the table + my $c = $self->creator( $tb_name ); + $c->cols({ + ID => { pos => 1, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + ForeignColName => { pos => 2, type => 'CHAR', size => 50 }, + ForeignColKey => { pos => 3, type => 'CHAR', size => 50 }, + File_Name => { pos => 4, type => 'CHAR', size => 255 }, + File_Directory => { pos => 5, type => 'CHAR', size => 255 }, + File_MimeType => { pos => 6, type => 'CHAR', size => 50 }, + File_Size => { pos => 7, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + File_URL => { pos => 8, type => 'CHAR', size => 255 }, + +# under consideration.... +# File_Width => { pos => 8, type => 'INT', unsigned => 1, regex => '^\d+$' }, +# File_Height => { pos => 9, type => 'INT', unsigned => 1, regex => '^\d+$' }, + + }); + $c->pk('ID'); + $c->ai('ID'); + $c->index({ fk_lookup => [ 'ForeignColName', 'ForeignColKey' ] }); + $c->create( $opts->{action} || 'force' ) or return; + + return 1; + +} +END_OF_SUB + +$COMPILE{_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _tbl { +#------------------------------------------------------------------------------- +# $obj->_tbl( $options ) +#---------- +# returns GT::SQL::Table for _File table +# + my ( $self, $opts ) = @_; + + $self->{table_object} and return $self->{table_object}; + + my $tbl = eval { + $self->new_table( $opts->{table} || ( + ( + $opts->{parent_tablename} + || $self->{parent_tablename} + || ( ref $self->{parent_table} ? + do { + my $prefix = $self->{connect}->{PREFIX}; + my $name = $self->{parent_table}->name(); + $name =~ s,^$prefix,,; + $name; + } + : + '' + ) ) . '_Files' + ) ); + }; + + return $self->{table_object} = $tbl; +} +END_OF_SUB + +$COMPILE{_parent_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _parent_tbl { +# ------------------------------------------------------------- +# $obj->_parent_tbl( $options ); +#---------- +# return the Table object for the parent table +# + my ( $self, $opts ) = @_; + $self->{parent_table} and return $self->{parent_table}; + return $self->_tbl( $self->{parent_table_name} || return ); +} +END_OF_SUB + +$COMPILE{File_Binary} = __LINE__ . <<'END_OF_SUB'; +sub File_Binary { +# ------------------------------------------------------------------- +# just returns true if the file is of binary type +# + my $self = shift; + defined $self->{File_Binary} and return $self->{File_Binary}; + $self->{file_fpath} and return $self->{File_Binary} = -B $self->{file_fpath}; + $self->{file_handle} and return $self->{File_Binary} = -B $self->{file_handle}; +} +END_OF_SUB + +$COMPILE{compare} = __LINE__ . <<'END_OF_SUB'; +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} +END_OF_SUB + +$COMPILE{get_filename} = __LINE__ . <<'END_OF_SUB'; +sub get_filename { +# ------------------------------------------------------------------- + my ($self, $fpath) = @_; + return +($fpath =~ /([^\\\/]+)$/)[0]; +} +END_OF_SUB + +$COMPILE{get_fh} = __LINE__ . <<'END_OF_SUB'; +sub get_fh { +# ------------------------------------------------------------------- + my ($self, $col, $values) = @_; + $values ||= {}; + + ref $values->{$col} and ref $values->{$col} ne 'SCALAR' and return $values->{$col}; + ref $values->{$col} eq 'SCALAR' and -f ${$values->{$col}} and -r _ and return GT::SQL::File->open(${$values->{$col}}); + return; +} +END_OF_SUB + +$COMPILE{pre_file_actions} = __LINE__ . <<'END_OF_SUB'; +sub pre_file_actions { +# ------------------------------------------------------------------- +# GT::SQL::File->pre_file_actions(); +#---------- +# called before Table::insert or Table::update to setup all the +# columns and run tests to ensure the file is appropropriate +# + my ( $package, $fcols, $set, $opts ) = @_; + +# check to make sure we have records + foreach my $col_name ( keys %$fcols ) { + defined $set->{$set} or next; + ref $set->{$set} and next; + $set->{$set} and -e $set->{$set} and next; + delete $set->{$set}; + } + +# now check to make sure records are of appropriate size + foreach my $col_name ( grep $set->{$_}, keys %$fcols ) { + if ( my $max_size = $fcols->{$col_name}->{file_max_size} || 0 ) { + if ( $max_size < -s $set->{$col_name} ) { + return $package->error( 'FILE_FILETOOBIG', 'WARN', "$set->{$col_name}", -s $set->{$col_name}, $max_size ); + } + } + } + +# just make backup files + my %fset; + foreach my $key ( keys %$fcols ) { + if ( $set->{$key} ) { + my $tmp = $set->{$key}; + $set->{$key} = $opts->{$key."_filename"} || $package->get_filename("$set->{$key}"); + $fset{$key} = $tmp; + } + if ( my $val = $set->{$key."_del"} ) { + $fset{$key."_del"} = $val; + } + }; + +# Remove any that have been deleted. + foreach my $key ( keys %$fcols ) { + if ( not $set->{$key."_del"} and exists $set->{$key} and not $set->{$key} ) { + delete $set->{$key}; + } + elsif ( $set->{$key."_del"} ) { + $set->{$key} = ''; + delete $set->{$key."_del"}; + } + } + + return wantarray ? %fset : \%fset; +} +END_OF_SUB + +package GT::SQL::File::Fh; + +# =================================================================== +# Magic File Handle, lets you print the file name, but also act like +# a file handle for read, just like CGI.pm. +# +use strict qw/vars subs/; +no strict 'refs'; +use vars qw/$FH %FH_Conns $AUTOLOAD/; +use overload + '""' => \&as_string, + 'cmp' => \&compare, + 'fallback' => 1; +$FH = 1; +%FH_Conns = (); + +sub open { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + goto >::SQL::File::Fh::new; +} + +sub new { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + my ( $pkg, $file, $opt ) = @_; + $file or return; + + my $fid = $FH++; + my $fname = sprintf( "FH%05d", $fid ); + my $fh = \do { local *{$fname}; *{$fname} }; + + CORE::open ($fh, $file || '') or return; + + bless $fh, $pkg; + + my $obj = GT::SQL::File->new({ + %{$opt||{}}, + file_name => GT::SQL::File->get_filename( $file ), + file_fpath => $file, + }) or return; + + $obj->File_Binary() and binmode $fh; + + $FH_Conns{$$fh} = $obj; + + return $fh; +} + +sub as_string { +# ------------------------------------------------------------------- +# Return the filename, strip off leading junk first. +# + my $self = shift; + return $FH_Conns{$$self}->{file_fpath}; +} + +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} + + +sub AUTOLOAD { +# ------------------------------------------------------------------- + my $self = shift; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + + my $fh_ref = $FH_Conns{$$self} or return; + + if ( $fh_ref->can($what) ) { + return $fh_ref->$what(@_) + } + elsif ($GT::SQL::File::PERMIT_REFS->{$what}) { + $fh_ref->{$what} = shift if @_; + return $fh_ref->{$what}; + } + else { + return $fh_ref->error('FILE_UNKNOWNREF', 'FATAL', $what); + } +} + +sub DESTROY { +# ------------------------------------------------------------------- +# Close file handle. +# + my $self = shift; + delete $FH_Conns{$$self}; + close $self; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::File - adds file upload and download abilities to GT::SQL + +GT::SQL::File::Fh - basic file object + +=head1 DESCRIPTION + +GT::SQL::File is not created directly by the user. This module is an +internal module for GT::SQL to provide the abilty to upload/download +files into a database column (or so it seems). + +GT::SQL::File::Fh is often accessed by the user as well as created +by the user whenever the user wants to store a file in the database. + +=head2 Creating a new FILE Column + +When a new table is created or a column is converted into 'FILE' +type, two things are created. First a column of type text which will +save the name of the file that is being stored. Secondly, a +piggy-back table will be greated under the name +"parent_table_name_File". This new table will store the location of +the uploaded/stored file and various associated file attributes. + +To create a new file table, include a column something like the +following. + + File_Col_Name => { + + # common parameters + pos => 2, + type => 'FILE', + + # location of the directory where + # all the files should be saved + file_save_in => '/tmp', + + # the method all the files are saved + # 'hashed', or 'simple' + # + # Defaults to hashed, and stores files in: + # file_save_in/hashed_letter/ID + # Simple stores files in: + # file_save_in/ID_OwnName.OwnExt + file_save_scheme => 'hashed', + } ... + +=head2 Inserting into the Column + +Once you have the table created, to insert: + + # Include all the modules + use GT::SQL; + use GT::SQL::File; + + # First create a file object pointing to the file + $f = GT::SQL::File->open('/path/to/file.txt'); + + # Then create a table object + $DB = GT::SQL->new('path/to/defs'); + $tbl = $DB->table(); + + # Create the record + # the file field can also be GT::CGI::Fh type + $rec = { + File_Column => $f, + # ... and all the other columns + }; + +# optionally, if you know the path to the file, you can provide +# a scalar ref of the path and the module will autoload +# the values +# simple scalar values will be dropped + $rec = { + File_Column => \"/path/to/file.txt" + # ... and all the other columns + }; + + # Then to store the file + $id = $tbl->add( $rec ); + +=head2 Retreiving from Column + +When a file has been stored. A standard select will only return +the name of the file. + +To get a filehandle, taking the previous example, if we know the +unique id, you can do the following. + + $fh = $tbl->file_info( 'File_Column', $id ); + +You can use this file handle just like any other, however hidden +behind are special functions that can be used as follows: + + print "Content-type: ", $fh->File_MimeType(), "\n\n"; + print <$fh>; + +The following is a partial list of special functions you may access. + + + Method Returns + ------ ------- + File_Name the basic filename + File_Directory path to the file + File_MimeType mimetype of the file + File_Size site of the file + File_RelativePath the permuted file and directory without root + File_URL if possible, the URL to the requested file + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: File.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $ + +=cut + diff --git a/site/glist/lib/GT/SQL/Monitor.pm b/site/glist/lib/GT/SQL/Monitor.pm new file mode 100644 index 0000000..f9c77fc --- /dev/null +++ b/site/glist/lib/GT/SQL/Monitor.pm @@ -0,0 +1,150 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Monitor +# Author: Jason Rhinelander +# CVS Info : +# $Id: Monitor.pm,v 1.2 2005/04/18 22:10:09 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Monitor; +use strict; +use vars qw/@EXPORT_OK $CSS/; +use Carp qw/croak/; +use GT::CGI qw/:escape/; +require Exporter; +@EXPORT_OK = qw/query/; + +use constant CSS => <<'CSS'; + +CSS + + +sub query { +# ----------------------------------------------------------------------------- +# Handles the 'SQL Monitor' function of various Gossamer Threads products. +# Takes a hash of options: +# table - any GT::SQL table object +# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text' +# html - ('tab' or 'text' mode) whether values should be SQL escaped and the whole thing surrouned by a
         tag
        +#   query - the query to run
        +#   css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
        +# Returned is a hash reference containing:
        +#   db_prefix - the database prefix currently in use
        +#   style - the value of the 'style' option
        +#   query - the query performed
        +#   rows - the number of rows returned by the query, or possibly the number of rows affected
        +#   results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
        +#   error - set to 1 if an error occured
        +#   error_connect - set to an error message if the database connection failed
        +#   error_prepare - set to an error message if the prepare failed
        +#   error_execute - set to an error message if the execute failed
        +#
        +    my %opts = @_;
        +
        +    $opts{table} and $opts{query} or croak "query() called without table and/or query options";
        +
        +    $opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
        +
        +    my %ret = (
        +        db_prefix => $opts{table}->{connect}->{PREFIX},
        +        pretty_style => $opts{pretty_style},
        +        query => $opts{query}
        +    );
        +
        +    my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
        +    my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
        +
        +    my $names = $sth->row_names;
        +
        +    $ret{rows} = $sth->rows || 0;
        +
        +    if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|sp_)/i) {
        +        my $table = '';
        +        my $data = $sth->fetchall_arrayref;
        +        if ($opts{style} and $opts{style} eq 'html') {
        +            $table .= defined $opts{css} ? $opts{css} : CSS;
        +            $table .= qq|\n|;
        +            $table .= "  \n";
        +            $table .= join '', map '    \n",
        +            @$names;
        +            $table .= "  \n";
        +            for (@$data) {
        +                $table .= "  \n";
        +                for (@$_) {
        +                    my $val = html_escape($_);
        +                    $val .= "
        " unless $val =~ /\S/; + $table .= qq| \n|; + } + $table .= " \n"; + } + $table .= "
        ' . html_escape($_) . "
        $val
        "; + } + elsif ($opts{style} and $opts{style} eq 'tabs') { + $table = $opts{html} ? '
        ' : '';
        +            for (@$data) {
        +                $table .= join("\t", $opts{html} ? (map html_escape($_), @$_) : @$_) . "\n";
        +            }
        +            $table .= "
        " if $opts{html}; + } + else { # style = 'text' + $table = $opts{html} ? '
        ' : '';
        +            my @max_width = (0) x @$names;
        +            for ($names, @$data) {
        +                for my $i (0 .. $#$_) {
        +                    my $width = length $_->[$i];
        +                    $max_width[$i] = $width if $width > $max_width[$i];
        +                }
        +            }
        +            $table = $opts{html} ? '
        ' : '';
        +            $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
        +            $table .= '|';
        +            for my $i (0 .. $#$names) {
        +                $table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($names->[$i]) : $names->[$i];
        +            }
        +            $table .= " \n";
        +            $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
        +            for (@$data) {
        +                $table .= '|';
        +                for my $i (0 .. $#$names) {
        +                    $table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($_->[$i]) : $_->[$i];
        +                }
        +                $table .= " \n";
        +            }
        +            $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
        +            $table .= $opts{html} ? '
        ' : ''; + } + $ret{results} = \$table; + } + else { + $ret{results} = "Rows affected: $ret{rows}"; + } + + return \%ret; +} + diff --git a/site/glist/lib/GT/SQL/Relation.pm b/site/glist/lib/GT/SQL/Relation.pm new file mode 100644 index 0000000..635f8c5 --- /dev/null +++ b/site/glist/lib/GT/SQL/Relation.pm @@ -0,0 +1,1897 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Relation +# Author : Jean-Michel Hiver +# $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Utility modules that makes it possible to treat joins between +# multiple tables almost as if it was a single table. +# + +package GT::SQL::Relation; +# ================================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERROR_MESSAGE/; + +$ERROR_MESSAGE = 'GT::SQL'; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.102 $ =~ /(\d+)\.(\d+)/; + +sub DESTROY {} + +sub new { +# ----------------------------------------------------------- +# new GT::SQL::Relation ( +# tables => { table name => object } +# debug => debug level, +# _err_pkg => package name, +# ); +# ------------------------------------------------- +# Constructs (or returns if it already exists) a +# new GT::SQL::Relation object with the parameters specified +# above. +# +# +# new GT::SQL::Relation ( $hashref ); +# ---------------------------------- +# Same thing, $hashref being a reference to a +# hash which would be similar to what's above. +# +# +# $obj->new(LIST); +# ----------------- +# Internal use only. Creates a new Relation object from $obj +# with list being a subset of the tables which are being +# contained in $obj. +# + my $class = shift; + + if (ref $class) { + # if the first argument is a reference, then we assume that we + # are constructing from a Relation object that handles all the + # data that has to be passed in. + my $this = $class; + my $class = ref $class; + + my @tables = map { (ref $_) ? $_->{name} : $_ } @_; + + my $opts = {}; + $opts->{_debug} = $this->{_debug} || $DEBUG; + $opts->{_err_pkg} = $this->{_err_pkg}; + $opts->{connect} = $this->{connect}; + $opts->{tables} = { map { $_ => $this->{tables}->{$_} } @tables }; + $opts->{tables_ord} = \@tables; + + return $class->new($opts); + } + else { + my $self = bless {}, $class; + my $opts = {}; + + if (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (@_ % 2 == 0) { $opts = { @_ } } + else { + $self->error("BADARGS", "FATAL", "new GT::SQL::Relation (HASH or HASHREF)"); + } + + # same thing for name - must be an array ref + ref $opts->{tables} eq 'HASH' or + return $self->error("BADARGS", "FATAL", "$class new(HASH_REF or HASH). name must be a ref to a list of table names."); + + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} if exists $opts->{_err_pkg}; + $self->{tables} = $opts->{tables}; + $self->{connect} = $opts->{connect}; + $self->{fk} = {}; + + # if an order was specified for the tables, use it, otherwise + # sort the tables in lexicographical order. + my @tables_ord = sort keys %{$self->{tables}}; + if ($opts->{tables_ord}) { @tables_ord = @{$opts->{tables_ord}} } + + $self->{tables_ord} = \@tables_ord; + + # this is a hash that has { $table names => $schema object } + $self->{last_where} = undef; + $self->{last_hits} = undef; + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; + } +} + +# ------------------------------------------------------------------------------------- # +# INSERT # +# ------------------------------------------------------------------------------------- # + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $obj->insert($col1 => $val1, +# ..., +# $coln => $valn, +# ); +# ----------------------------- +# Will fill +# the tables whenever it can according to the +# insert parameters. +# +# returns TRUE if insert succeeded, +# FALSE otherwise. +# +# $obj->insert($hashref); +# ------------------------------ +# Same as above. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_insert($split); + if (! $added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +$COMPILE{add} = __LINE__ . <<'END_OF_SUB'; +sub add { +# ----------------------------------------------------------- +# add() : Adds a record into the current relation object, and +# returns a hash of primary key => value. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_add($split); + if (!$added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# SELECT # +# ------------------------------------------------------------------------------------- # + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where +# condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that +# you wish returned. If none are specified all +# fields will be returned. +# + my $self = shift; + $self->connect or return; + +# Get a list of fields to select. + my (@fields, @cond, $left_join); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_}; } + elsif (not ref $_) { ($_ eq 'left_join') ? ($left_join = 1) : push @fields, $_; } + else { push @cond, $self->_build_cond($_); } + } + @fields = map { $self->_complete_name($_) } grep { defined and length } @fields; + @fields or (@fields = ('*')); + + my $fields = join ',' => @fields; + my $condition = @cond > 1 ? GT::SQL::Condition->new(@cond) : $cond[0]; + +# building the join condition for this query + my @relations = values %{$self->{tables}}; + my $join = $self->_join_query(\@relations); + +# building the select options, if any + my $sel_opts = ''; + if (defined $self->select_options) { $sel_opts = " " . join " ", $self->select_options } + $self->{sel_opts} = undef; + +# Any fk specifics + $self->{fk} ||= {}; + my $orig_fk = {}; + for my $table (keys %{$self->{fk}}) { + if (defined $self->{fk}->{$table}) { + $orig_fk->{$table} = $self->{fk}->{$table}; + $self->{tables}->{$table}->{schema}->{fk}->{$table} = $self->{fk}->{$table}; + } + } + + my $sql; + if ($left_join) { + my $tables = $self->{tables_ord}->[0] . ' LEFT OUTER JOIN ' . $self->{tables_ord}->[1] . ' ON ' . $join; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "WHERE ($string)" if $string; + } + + $sql = qq!SELECT $fields FROM $tables $cond_sql!; + $sql .= $sel_opts if $sel_opts; + } + else { + my $tables = join ',' => sort keys %{$self->{tables}}; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "($string)" if $string; + } + + my $where = ($cond_sql or $join) ? "WHERE " : ""; + $where .= "$join " if $join; + $where .= 'AND ' if $join and $cond_sql; + $where .= "$cond_sql" if $cond_sql; + $sql = qq!SELECT $fields FROM $tables $where!; + $sql .= $sel_opts if $sel_opts; + } + + my $sth = $self->{driver}->prepare($sql) or return; + $sth->execute or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it now +# without an additional query. + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined($3)) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif ($1) { + ($limit, $offset) = ($1, $2 || 0); + } + else { + ($offset, $limit) = ($4, $5); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + + $self->{sel_opts} = []; + +# Save the last query for future use. + $self->{last_where} = $condition ? $condition->clone : undef; + + for ( keys %$orig_fk ) { + $self->{tables}->{$_}->{schema}->{fk}->{$_} = $orig_fk->{$_}; + } + $self->{fk} = {}; + return $sth; +} + +$COMPILE{join_on} = __LINE__ . <<'END_OF_SUB'; +sub join_on { +# ------------------------------------------------------------------- +# Change how tables join + my ( $self, $tb, %change ) = @_; + my $p = $self->prefix; + $tb = $p . $tb; + return unless exists $self->{tables}{$tb}; + for my $table ( keys %change ) { + my $cp = $p . $table; + next unless exists $self->{tables}{$cp}; + $self->{tables}->{$tb}->{schema}->{fk}->{$cp} = $change{$table}; + } +} +END_OF_SUB + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + my %join; + foreach my $relation (@$relations) { + my $relation_name = $relation->{name}; + my @join_tables = keys %{$relation->{schema}->{fk}}; + foreach my $join_table (@join_tables) { + if ($self->{tables}->{$join_table}) { + my $fk = $relation->{schema}->{fk}->{$join_table}; + for my $key (keys %$fk) { + $join{"$relation_name.$key"} = "$join_table.$fk->{$key}" unless $relation_name eq $join_table; # Ignore foreign keys to the same table + } + } + } + } + return join " AND ", map "$_ = $join{$_}", keys %join; +} + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want +# prepended to your search. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_ > 0; + if (wantarray) { ($self->{sel_opts}) ? @{$self->{sel_opts}} : () } + else { ($self->{sel_opts}) ? $self->{sel_opts} : [] } +} + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ----------------------------------------------------------- +# $obj->query($HASH or $CGI); +# ---------------------------- +# Performs a query based on the options in the hash. +# $HASH can be a hash ref, hash or CGI object. +# +# Returns the result of a query as fetchall_arrayref. +# + my $self = shift; + my $sth = $self->_query(@_) or return; + return $sth->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ----------------------------------------------------------- +# $obj->query_sth($HASH or $CGI); +# -------------------------------- +# Same as query but returns the sth object. +# + shift->_query(@_) +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# DELETE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{delete} = __LINE__ . <<'END_OF_SUB'; +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition, $opt); +# -------------------------------- +# $condition is a condition on the current +# join relation, +# +# $opt is a string which can be either 'abort', +# 'ignore', or 'cascade'. +# + my $self = shift; + my $cond = shift; + my $opt = shift || 'cascade'; + + $cond = $self->_build_cond($cond); + + $self->{last_where} = $cond ? $cond->clone : undef; + + my $rows; + if ($opt eq 'ignore') { + my $split = $self->_split_fields($cond); + for (keys %{$split}) { + $rows += $self->{$_}->delete($split->{$_}, 'ignore') or return; + } + } + elsif ($opt eq 'abort') { + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, $cond) or return; + if (!$q->rows) { + $rows = "0E0" unless ($q->rows); + } + else { + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + foreach my $referencing ($self->_referencing_relations) { + unless ($self->_can_delete($h, $referencing)) { + return $self->error("DEPENDENCY", "WARN", $referencing); + } + } + } + $rows = $self->_delete_cascade($cond->new_clean); + } + } + elsif ($opt eq 'cascade') { + $rows = $self->_delete_cascade($cond) or return; + } + return ($rows == 0) ? '0E0' : $rows; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# deletes all the records in this relation +# + my $self = shift; + my $opt = shift || 'abort'; + foreach my $rel ($self->_referencing_relations) { ($rel->delete_all($opt)) ? next : return } + foreach my $rel ($self->_referenced_relations) { ($rel->delete_all($opt)) ? next : return } + return 1; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# UPDATE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# ----------------------------------------------------------- +# $obj->update($hashref, $hashref); +# $obj->update($hashref, $condition); +# ------------------------------------ +# $hashref are the fields to update +# +# $condition is a condition on the current +# join relation. +# +# A limitation exists: in a relation one to many, +# it is not possible to perform an update on the +# attributes that are in the "one" entity. +# + my ($self, $hash, $cond) = @_; + (ref $self and ref $hash and ref $cond) or $self->error("BADARGS", "FATAL", '$obj->update(HASH, GT::SQL::Condition or HASH)'); + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + $cond = $self->_build_cond($cond); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + my ($upd, $rec) = ($hash->{$rel->{name}}, $h); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec2 = {}; + my $prefix = $rel->{name} . "."; + foreach my $col (keys %{$rel_rec}) { + my $col2 = $col; + $col2 =~ s/^\Q$prefix\E//; + $rel_rec2->{$col2} = $rel_rec->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + + unless (defined $rel->update($upd, $rel_rec2)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + + my $in = $self->common_param(@_); + + # first of all complete $in attributes + my ($hash, $cond); + for my $col (keys %$in) { + if (my $completed = $self->_complete_name($col, 1)) { + $hash->{$completed} = $in->{$col}; + } + } + + # let's build the $condition + my $condition = { map { + $_ => $hash->{$_} + } $self->pk }; + + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + + $cond = $self->_build_cond($condition); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(\@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec = {}; + foreach my $col (keys %{$h}) { + next unless $col =~ /^\Q$rel->{name}\E\./; + my $col2 = $col; + $col2 =~ s/^[^.]+\.//; + $rel_rec->{$col2} = defined($hash->{$rel->{name}}->{$col2}) ? $hash->{$rel->{name}}->{$col2} : defined($hash->{$rel->{name}}->{$col}) ? $hash->{$rel->{name}}->{$col} : $h->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + unless (defined $rel->modify($rel_rec)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# COUNT/GET # +# ------------------------------------------------------------------------------------- # + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# $obj->get($condition, $opt); +# ----------------------------- +# $condition is the condition for the row that has to be +# retrieved. $opt can be 'ARRAY' or 'HASH'. The first row +# of the query is returned, which makes the get method +# mostly useful to retrieve rows from the primary key +# values. +# + my $self = shift; + my $cond = shift; + if (ref $cond eq 'ARRAY') { $cond = { @{$cond} } } + my $method = shift || 'HASH'; + $method = (uc $method eq 'ARRAY') ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond) or return; + return $sth->$method(); +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# ACCESSSORS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the relation columns as a hash which has +# the columns names as a key and their type as a +# value. +# + my $self = shift; + my @res; + if (@_) { $self->error('BADARGS', 'FATAL', '$obj->cols;') } + +# if the number of table objects that handles the current +# relation object equals zero, then returns an empty hash. + my @names = $self->name; + if (@names == 0) { return {} } + else { + my $res = {}; + my @referencing = $self->_referencing_relations; + my @referenced = $self->_referenced_relations; + if (@referenced) { + +# if in the current Relation object there exists some +# tables which are referenced by other tables within +# the current relation object, then + my %referenced_cols = $self->new(@referenced)->cols; + my @referenced_cols = keys %referenced_cols; + +# remove columns which are referenced by referencing +# tables because we don't wanna have these duplicates. + my @rem_cols; + foreach my $referencing (@referencing) { + foreach my $target (keys %{$referencing->{schema}->{fk}}) { + if (defined $self->{tables}->{$target}) { + push @rem_cols, map { $target .'.'. $_ } keys %{$referencing->{schema}->{fk}->{$target}}; + } + } + } + my @cols_left = _minus(\@referenced_cols, \@rem_cols); + map { $res->{$_} = $referenced_cols{$_} } @cols_left; + } + +# add then all low level columns, and return. + foreach my $referencing (@referencing) { + my %referencing_cols = %{$referencing->{schema}->{cols}}; + map { $res->{$referencing->{name} .'.'. $_} = $referencing_cols{$_} } keys %referencing_cols; + } + + return $res unless wantarray; + +# Wantarray has been set so create a copy of the res whose +# first and second level references can be clobbered. +# This assumes that the values side of the res will +# always been hashrefs + my %res_copy = %$res; + foreach my $res_name ( keys %res_copy ) { + + my %res_data = %{$res_copy{$res_name}}; + $res_copy{$res_name} = \%res_data; + + foreach ( keys %res_data ) { + if ( ref $res_data{$_} eq 'HASH' ) { + $res_data{$_} = {%{$res_data{$_}}}; + } + elsif ( ref $res_data{$_} eq 'ARRAY' ) { + $res_data{$_} = [@{$res_data{$_}}]; + } + } + } + + return %res_copy; + } +} +END_OF_SUB + +$COMPILE{col_names} = __LINE__ . <<'END_OF_SUB'; +sub col_names { +# ----------------------------------------------------------- +# Returns the columns names sorted the right order. +# + my $self = shift; + my %cols = $self->cols; + return sort { my $ret = $self->_col_cmp($a, $b); $ret } keys %cols; +} +END_OF_SUB + +# self explainatory +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { return shift->col_names(@_) } +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns a list of current relation names +# +# $obj->name(@names); +# -------------------- +# Returns a list of objects maching specified name. +# + my $self = shift; + if (@_) { + return map $self->{tables}->{$_}, @_ + } + else { + my @names = keys %{$self->{tables}}; + return wantarray ? @names : \@names; + } +} + +$COMPILE{unique} = __LINE__ . <<'END_OF_SUB'; +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns an array containing all the array refs +# for all the uniques. +# +# $obj->unique($field_name); +# --------------------------- +# Returns true if the field is unique. False otherwise. +# + my $self = shift; + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my %unq = %{$table->{schema}->{unique}}; + foreach my $unq (values %unq) { push @res, [ map { $table_name . "." . $_ } @{$unq} ] } + } + if (@_ == 1) { + my $s = shift; + return scalar grep { $s eq $_ } map { @{$_} } @res; + } + return wantarray ? @res : \@res; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns an array containing all the array refs +# for all the indexes. +# + my $self = shift; + if (@_ == 0) { + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my @idx = values %{$table->{schema}->{index}}; + foreach my $idx (@idx) { push @res, [ map { $table_name . "." . $_ } @{$idx} ] } + } + return wantarray ? @res : \@res; + } + else { return $self->error('BADARGS', 'FATAL', '$obj->index;') } +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# This method returns the columns reprensenting what +# would be the primary key of our JoinRelation if it +# ever existed. +# +# Tables which are referenced by other tables primary +# key shall not be exported, because they are the 'one' +# entities in a one-to-many relation. +# +# $obj->pk($field_name); +# ----------------------- +# Returns true if the field is in the primary +# key list. Returns false otherwise. +# + my $self = shift; + if (@_ == 0) { + my @result = (); + my @referencing = $self->_referenced_relations; + foreach my $referencing (@referencing) { push @result, map { $referencing->{name} .'.'. $_ } @{$referencing->{schema}->{pk}}; } + return sort { my $ret = $self->_col_cmp($a, $b); $ret; } @result; + } + elsif (@_ == 1) { + my $name = $self->_complete_name(shift); + return scalar grep { $name eq $_ } @{$self->{schema}->{pk}}; + } + else { $self->error('BADARGS', 'FATAL', '$obj->pk;') } +} +END_OF_SUB + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# returns a list of relation names which are referenced +# by the current relation. +# +# $obj->fk(RELATION_NAME); +# ------------------------- +# returns a hashref for relation RELATION_NAME which +# keys are the current relation "source" schema and which +# values are the "target" schema. +# + my $self = shift; + if (@_ > 1) { $self->error('BADARGS', 'FATAL', '$obj->fk; or $obj->fk($table_name)') } + if (@_ == 1) { + my $res = {}; + my $target = shift; + foreach my $rel (values %{$self->{tables}}) { + foreach my $rel_target (keys %{$rel->{schema}->{fk}}) { + if ($target eq $rel_target) { + my $h = $rel->{schema}->{fk}->{$rel_target}; + foreach my $k (keys %{$h}) { $res->{$rel->{name} .'.'. $k} = $h->{$k} } + } + } + } + return wantarray ? %{$res} : $res; + } + else { + my @res; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + push @res, $fk unless ($self->{tables}->{$fk}); + } + } + return wantarray ? @res : \@res; + } +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# $obj->fk_tables; +# ---------------- +# Returns a list of table that reference any +# of the table that's in the current joinrelation. +# +# $obj->fk_tables($table_name); +# ------------------------------ +# Returns true if $table_name is the name of a +# table that's referencing any of the tables that's +# in the current joinrelation. +# + my $self = shift; + my @result = $self->_minus( [ map { @{$_->{schema}->{fk_tables}} } values %{$self->{tables}} ], [ $self->name ] ); # very evil (c) + if (@_ == 1) { + my $check = shift; + return scalar grep { $check eq $_ } @result; + } + return wantarray ? @result : \@result; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + return wantarray ? [@{$self->unique}, @{$self->index}] : @{$self->unique}, @{$self->index}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# ai makes no sense in a Relation therefore I return nothing +# + my $self = shift; + my @res; + foreach my $rel (values %{$self->{tables}}) { + my $ai = $rel->{schema}->{ai} or next; + $ai = $rel->{name} . '.' . $ai; + push @res, $ai; + } + return unless @res; + return wantarray ? @res : \@res; + +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# INTERNAL METHODS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{_build_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_cond { +# ----------------------------------------------------------- +# this subroutine is made to build conditions which may not +# be a Condition object for selects and deletes. +# + my ($self, $condition) = @_; + my $prefix = $self->{connect}->{PREFIX}; + if (! defined $condition) { + return; + } + elsif (ref $condition eq 'HASH') { + my $tmp = new GT::SQL::Condition; + while (my ($col, $val) = each %$condition) { + $col = $self->_complete_name($col); + $tmp->add($col => '=' => $val); + } + return $tmp; + } + elsif (ref $condition eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$condition}); + return $tmp; + } + elsif (length $prefix and (ref $condition eq 'GT::SQL::Condition')) { + $self->_build_prefixed_cond($prefix, $condition); + return $condition; + } + else { + return $condition; + } +} +END_OF_SUB + +$COMPILE{_build_prefixed_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_prefixed_cond { +# ----------------------------------------------------------- +# $obj->_build_prefixed_cond($prefix, $cond) +# --------------------------------- +# + my ($self, $prefix, $condition) = @_; + foreach (@{$condition->{cond}}) { + if (ref $_ eq 'ARRAY') { + if ($_->[0] =~ /^[\w\.]+$/) { + $_->[0] = $self->_complete_name($_->[0]); + } + } + elsif (ref $_ eq 'GT::SQL::Condition') { + $self->_build_prefixed_cond($prefix, $_); + } + } + return $condition; +} +END_OF_SUB + +$COMPILE{_complete_name} = __LINE__ . <<'END_OF_SUB'; +sub _complete_name { +# ----------------------------------------------------------- +# Returns a Table.Attribute name of a column given Attribute, if possible. +# Takes an optional second argument - if passed and true, seeing 'abc.xyz' will +# return undef if 'abc' isn't a valid table. Without the true second argument, +# such a situation causes a fatal error. +# + my $self = shift; + my $col = shift or return $self->error('BADARGS', 'FATAL', "No column name specified."); + my $ignore_unknown = shift; + +# if column name is a scalar reference, just throw in the raw colname + ref $col eq 'SCALAR' and return $$col; + +# try to handle fully qualified column names + my ($relname, $colname) = split /\./, $col; + if ($relname and $colname) { + if (exists $self->{tables}->{$relname}) { + return $col; + } + else { + my $prefix = $self->{connect}->{PREFIX}; + if (exists $self->{tables}->{$prefix.$relname}) { + return $prefix.$relname.".".$colname; + } + elsif ($ignore_unknown) { + return undef; + } + else { + return $self->error('BADCOLS', 'FATAL', $col); + } + } + } + +# Otherwise, no . in column name. + my $found = 0; + my $return = $col; + foreach my $rel (values %{$self->{tables}}) { + my %h = %{$rel->{schema}->{cols}}; + if (exists $h{$col}) { + $found++; + $return = $rel->{name} . '.' . $col; + } + } + if ($found > 1) { + return $self->error('BADCOLS', 'FATAL', $col); + } + return $return; +} +END_OF_SUB + +$COMPILE{_col_cmp} = __LINE__ . <<'END_OF_SUB'; +sub _col_cmp { +# ----------------------------------------------------------- +# $a is something like TABLE.COL +# this method is used to sort the columns in the right order. +# + my ($self, $a, $b) = @_; + + $a and !$b and return -1; + $b and !$a and return 1; + !$a and !$b and return 0; + + my $one = $self->_complete_name($a); + my $two = $self->_complete_name($b); + my ($one_tab, $one_col) = split /\./, $one; + my ($two_tab, $two_col) = split /\./, $two; + + if ($one_tab eq $two_tab) { + return 0 if (!$one_tab or !$two_tab); + return ($self->{tables}->{$one_tab}->{schema}->{cols}->{$one_col}->{pos} <=> $self->{tables}->{$one_tab}->{schema}->{cols}->{$two_col}->{pos}); + } + else { + my @tables_ord = @{$self->{tables_ord}}; + while (my $table = shift(@tables_ord)) { + if ($table eq $one_tab) { return -1 } + if ($table eq $two_tab) { return 1 } + } + return 0; + } +} +END_OF_SUB + +$COMPILE{_insert} = __LINE__ . <<'END_OF_SUB'; +sub _insert { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $sth = $rel->insert($split->{$rel->{name}}) or return; + unless ($sth) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $sth = $rel->insert(%{$split->{$name}}); + unless ($sth) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $column_hash (values %added) { + foreach my $col (keys %{$column_hash}) { + $ids{$col} = $column_hash->{$col}; + } + } + return \%ids; +} +END_OF_SUB + +$COMPILE{_add} = __LINE__ . <<'END_OF_SUB'; +sub _add { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $id = $rel->add($split->{$rel->{name}}) or return; + unless ($id) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $id = $rel->add($split->{$name}); + unless ($id) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $table_name ( keys %added ) { + foreach my $col (keys %{$added{$table_name}}) { + $ids{"$table_name.".$col} = $added{$table_name}->{$col}; + } + } + + return \%ids; +} +END_OF_SUB + +$COMPILE{_minus} = __LINE__ . <<'END_OF_SUB'; +sub _minus { +# ----------------------------------------------------------- +# _minus($ary1, $ary2); +# ---------------------- +# $ary1 and $ary2 being two array refs, +# returns a list of all elements in $ary1 +# which are not in $ary2. +# + my ($self, $ary1, $ary2); + if (@_ == 0 || @_ == 1) { return } + elsif (@_ == 2) { ($ary1, $ary2) = @_ } + else { ($self, $ary1, $ary2) = @_ } + my @a1 = @{$ary1}; + my @a2 = @{$ary2}; + my @result; + foreach my $elt1 (@a1) { + my $push = 1; + foreach my $elt2 (@a2) { + $push = 0 if ($elt1 eq $elt2); + } + push @result, $elt1 if ($push == 1); + } + return @result; +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ----------------------------------------------------------- +# $self->_query; +# -------------- +# This function takes in special query arguments and turns them +# into a $opts array before doing the actual select on the +# database. +# + my $self = shift; + scalar $self->name() or return $self->error("NOTABLE", "FATAL"); + my $opts = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->_query( HASH or HASH_REF or CGI ) only.'); + + +# Strip out values that are empty or blank (as query is generally +# derived from cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} =~ /\S/ } keys %$opts; + $opts = \%input; + +# Prefix column names. + foreach my $field (keys %$opts) { + if ($field =~ /^(.*)-(gt|lt|le|ge|opt)$/) { + my $opt = $2; + if (my $full = $self->_complete_name("$1", 1)) { + $opts->{"$full-$opt"} = $opts->{$field}; + } + } + else { + if (my $full = $self->_complete_name($field, 1)) { + $opts->{$full} = $opts->{$field}; + } + } + } + +# Set search options and get query condition. + my $in = $self->_get_search_opts($opts); + my $cond = $self->build_query_cond($opts, scalar $self->cols); + + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless ($in->{mh} == -1); + my @sel = (); + if ($cond) { push @sel, $cond } + if ($in->{rs} and $cond) { push @sel, $in->{rs} } + if ($opts->{left_join} and $cond) { push @sel,'left_join' } + my $sth = $self->select(@sel) or return; + return $sth; +} +END_OF_SUB + +$COMPILE{_split_schema} = __LINE__ . <<'END_OF_SUB'; +sub _split_schema { +# ----------------------------------------------------------- +# $obj->_split_schema($hashref); +# ------------------------------- +# Turns { Table1.Attribute1 => value1, +# Table1.Attribute2 => value2, +# Table2.Attribute1 => value3 } +# +# into { Table1 => { Attribute1 => value1, +# Attribute2 => value2 } +# Table2 => { Attribute1 => value1 } } +# +# $obj->_split_schema($col1 => $val1, +# ..., +# $coln => $valn); +# +# it also looks if a field is referencing +# another, and if so duplicates the field +# key and value in the target table provided +# that this target table is in the current +# relation object. +# + my $self = shift; + my $arg; + if (ref $_[0] eq 'HASH') { $arg = shift } + elsif (not @_ % 2 and defined $_[0]) { $arg = {@_} } + else { return $self->error('BADARGS', 'FATAL', '$self->_split_schema(%hash)') } + my $result = {}; + +# first of all, some of the fields may not be specifying +# the table they belong to. + foreach my $col (keys %{$arg}) { + if (my $relname = $self->_complete_name($col, 1)) { + $arg->{$relname} = delete $arg->{$col}; + } + } + +# then, we separate fields in function of +# the table name that they have. + foreach my $complete_field (keys %{$arg}) { + next if (CORE::index($complete_field, '.') == -1); + my ($tablename, $fieldname) = split /\./, $complete_field; + $result->{$tablename} = {} unless (defined $result->{$tablename}); + $result->{$tablename}->{$fieldname} = $arg->{$complete_field}; + } + +# then, for each relation in our join object, complete +# names in $result + foreach my $relation (values %{$self->{tables}}) { + my $relation_name = $relation->{name}; + + # for all $relation foreign keys which are in $self + my %target_relation_names = %{$relation->{schema}->{fk}}; + + foreach my $target_relation_name (keys %target_relation_names) { + + # if the target relation exists in our join relation + # object and in our $hash + if (defined $self->{tables}->{$target_relation_name} and defined $result->{$target_relation_name}) { + + # then in $hash we set the values of the fields + # for the target relation depending on the values + # of the source relation. + my $fk = $relation->{schema}->{fk}->{$target_relation_name}; + foreach my $key (keys %{$fk}) { + my $value = $fk->{$key}; + $result->{$target_relation_name} = {} unless defined $result->{$target_relation_name}; + + my $fk_key = $relation->{schema}->{fk}->{$target_relation_name}->{$key}; + $result->{$relation_name}->{$key} = $result->{$target_relation_name}->{$fk_key} + if defined $result->{$target_relation_name}->{$fk_key}; + } + } + } + } + return $result; +} +END_OF_SUB + +$COMPILE{_referenced_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referenced_relations { +# ----------------------------------------------------------- +# $obj->_top_level_relations; +# --------------------------- +# This method returns the relations in the current +# which are referenced by other tables in the current join +# relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + my @referenced = _minus([ values %{$self->{tables}} ], [ map {$self->{tables}->{$_}} keys %names ]); + return @referenced; +} +END_OF_SUB + +$COMPILE{_referencing_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referencing_relations { +# ----------------------------------------------------------- +# $obj->_referencing_relations; +# ----------------------------- +# This method returns the tables in the current +# relation which are not referenced by any other +# tables in this relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + return map {$self->{tables}->{$_}} keys %names; +} +END_OF_SUB + +$COMPILE{_delete_cascade} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cascade { +# ----------------------------------------------------------- +# $obj->_delete_cascade($cond); +# ------------------------------ +# This method is used internaly to delete all the rows +# that match $cond for that joinrelation object. +# + my $self = shift; + my $count = 0; + + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, @_) or return; + while (my $array = $q->fetchrow_arrayref) { + $count++; + +# for each row that matches the condition + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + +# delete each low-level table rows (i.e. referencing tables) + foreach my $referencing ($self->_referencing_relations) { + $self->_delete_row($h, $referencing); + } + +# then delete each top-level table rows, if possible +# this may be broken when using tables with hierarchy +# level > 2. + foreach my $referenced ($self->_referenced_relations) { + if ($self->_can_delete($h, $referenced)) { $self->_delete_row($h, $referenced) } + } + } + return $count == 0 ? "0E0" : $count; +} +END_OF_SUB + +$COMPILE{_can_delete} = __LINE__ . <<'END_OF_SUB'; +sub _can_delete { +# ----------------------------------------------------------- +# $obj->_can_delete($record, $relation); +# --------------------------------------- +# Returns true if the record can be deleted +# from this relation without breaking dependancies +# or false otherwise. +# + my ($self, $rec, $rel) = (@_); + ref $rel or $rel = $self->{tables}->{$rel}; + + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# for all the schemas that exist in the database + foreach my $schema (keys %GT::SQL::Table::DATABASE) { + $self->debug("CREATING A NEW TABLE OBJECT") if ($self->{_debug} > 2); + + my $relation = $self->new_table($schema); + foreach my $relation_targetname ($relation->{schema}->{fk}) { + if ($relation_targetname eq $rel->{name}) { + my $schem = $relation->{schema}->{fk}->{$relation_targetname}; + +# I must make a copy of this because it's a reference from Schema +# and can potentially be used later, therefore it should not be +# modified. + my $schema = { map { $_ => $schem->{$_} } keys %{$schem} }; + foreach my $key (keys %{$schema}) { $schema->{$key} = $rel_rec->{$schema->{$key}} } + $relation->count($schema) and return 0; + } + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_row} = __LINE__ . <<'END_OF_SUB'; +sub _delete_row { +# ----------------------------------------------------------- +# $obj->_delete_row($record, $relation); +# --------------------------------------- +# + my ($self, $rec, $rel) = (@_); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + foreach my $col (keys %{$rel_rec}) { delete $rel_rec->{$col} unless (defined $rel_rec->{$col}) } + $rel->delete($rel_rec, 'cascade'); +} +END_OF_SUB + +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { +#------------------------------------------------------------------------------- + my $self = shift; + $_[0] and $self->{_file_cols} = undef; + $self->{_file_cols} and return %{$self->{_file_cols}}; + my %rec = (); + for my $table_name ( keys %{$self->{tables} } ) { + my %trec = $self->{tables}->{$table_name}->_file_cols() or next; + $rec{$table_name} = \%trec; + } + return %rec; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Relation - manage multiple table joins + +=head1 SYNOPSIS + + my $relation = $DB->table('Company', 'Employees'); + my $sth = $relation->select( { + Company.Name => 'Gossamer Threads', + Employees.Name => 'Alex Krohn' + }, ['Employees.Salary', 'Company.City'] ); + my ($salary, $city) = $sth->fetchrow_array; + print "Alex works in $city and earns $salary!\n"; + +=head1 DESCRIPTION + +This module aims at emulating a set of tables that are related to each other +via the use of foreign keys just as if it was one big table. + +The module interface should be as compatible as possible with GT::SQL::Table, +thus you should be familiar with GT::SQL::Table before even reading this. + +This documentation explains the differences between GT::SQL::Relation and +GT::SQL::Table and how the module internally works as well. + +=head2 How it works + +GT::SQL supports the concept of foreign keys (also known as external +references). Basically, two tables that are linked together using external +references can look like that: + + .-------------. .---------. + | EMPLOYEE | | COMPANY | + `-------------' `---------' + | ID | .--->ID | + | COMPANY_ID ----' | NAME | + | NAME | `---------' + | SALARY | + `-------------' + +In this example, the COMPANY_ID attribute relates the fact that a an EMPLOYEE +belongs to such or such COMPANY. + +Utilizing a Relation object can make these tables look like that: + + .----------------------. + | EMPLOYEE-COMPANY | + `----------------------' + | EMPLOYEE.ID | + | EMPLOYEE.COMPANY_ID | + | EMPLOYEE.NAME | + | EMPLOYEE.SALARY | + | COMPANY.NAME | + `----------------------' + +The first thing that can be seen from there is that COMPANY.ID has disappeared +from this "Virtual" table. + +Indeed, as for a given "joined" record this value must be the same in both +tables, representing the values twice would have been a useless source of +confusion. + +=head2 SELECT statements + +Selecting from a Relation object is pretty simple using the GT::SQL module. As +the interface is (almost) the same as L, the GT::SQL wrapper +returns Table or Relation objects depending on the arguments that are passed to +table. + + # This gives me a GT::SQL::Table object for + # the EMPLOYEE table. + my $emp = $sql->table('EMPLOYEE'); + + # This gives me a GT::SQL::Relation object for + # the relation EMPLOYEE-COMPANY tables + my $emp_cmp = $sql->table('EMPLOYEE','COMPANY'); + +From there, performing a select is pretty simple: + + # select all the people from a real cool company + my $sth = $emp_cmp->select( { COMPANY.NAME => "Gossamer Threads" } ) + +Internally, the generated SQL query would look like: + + SELECT EMPLOYEE.ID, EMPLOYEE.COMPANY_ID, EMPLOYEE.NAME + EMPLOYEE.SALARY, COMPANY.NAME + FROM EMPLOYEE, COMPANY + WHERE COMPANY.NAME = 'Gossamer Threads' AND + EMPLOYEE.COMPANY_ID = COMPANY.ID + +Note that the join condition is computed and automatically appended at the end +of the query, so you do not have to worry about this. + +=head2 SELECT options + +The select options for relation are similar to that of table, you have +select_options() which will be set for the next query done. Example: + + $relation->select_options("LIMIT 10"); + +This would append 'LIMIT 10' to your next select query. Another useful thing +is join_on(). join_on() allows you to specify the FK relation for the nextr +select. This overrides what is in the def files. It is useful for allowing you +to have one table which will be join differently depending on what you are +doing. The argument to this are the same as to fk(). +Example: + + $relation->join_on( remote_table => { local_column => remote_column } ); + +The FK relation will be changed to this the next time you call select() but +then it will be cleared. + +=head2 Listing the relation columns + +* As previously said, the cols() method when invoked on a GT::SQL::Relation +object does not return all the columns, removing the duplicate external +references. So, how does it decides which column to keep and which one to +return? + +In the EMPLOYEE-COMPANY example we have the constraint +EMPLOYEE.COMPANY_ID => COMPANY.ID and it keeps COMPANY_ID, i.e. the foreign key +instead of the key itself. + +=head2 Relation primary key + +* The pk() method has to return the table primary key. The property of a primary +key is that it is a non-null unique record identifier. When pk() is invoked on +a Relation object, this base definition is applied to construct the object +primary key. + +To find a unique set of fields that makes a good primary key for a Relation +object, the following, simple algorithm is used: + + . . + . for each table . + . if the table is not referenced by another table that . + . is in the current relation . + . do . + . append the current table's primary key fields to . + . the Relation primary key fields . + . end-do . + . end-if . + . end-for . + . . + +This algorithm selects all the tables that represent the "many" in one-to-many +relations, and for all these tables add a list of fields which ensure a record +uniqueness. + +=head2 Foreign keys management + +* When invoked on a GT::SQL::Table object, the fk() method returns a hash which +has the following general structure: + + { + target_table_1 => { + source_col_1 => target_col_1, + source_col_2 => target_col_2 + }, + target_table_2 => { + source_col_1 => target_col_1 + } + } + +The GT::SQL::Relation module returns a hash which has the same structure. The +only difference is that it does not returns the external references which are +managed internally. + +This is done for two reasons: As one field is removed from a Relation table, it +would not have been very logical to return a structure that point to +non-existent fields. + +Moreover, these internal references from the "Relation" point of view have +nothing to do with the external world and thus should not be shown. + +(i.e. EMPLOYEE.COMPANY_ID |===> COMPANY.ID would not count in our example) + +=head2 Inserting data + +The interface for inserting data in a Relation is the same as the one that is +being used for Table. However, because rows are being inserted in a relation +one-to-many, things internally work a bit differently. + +The Relation insert() method takes an optional argument, which can be +'complete' or 'abort' (default being complete). + +insert() splits the relation columns into separate records that can be inserted +in a single table. However, some of the records may exist already! + +for example, if we perform: + + $sql = shift; # our GT::SQL object + $rel = $sql->table(qw/EMPLOYEE COMPANY/); + $rel->insert({ + 'EMPLOYEE.NAME' => $your_name, + 'EMPLOYEE.SALARY' => $big_buck, + 'COMPANY.NAME' => "Gossamer Threads" + }); + +Obviously the company "Gossamer Threads" already exists, but you were not in +the "EMPLOYEE" table. Thus, when 'complete' is specified (it is the default +option), the program will not complain if a record to insert already exists but +just warns and continue the insertion work. + +In other words, Gossamer Threads exists already and it will not be inserted +twice, but the employee will still be inserted and will belong to this company. + +On the other hand, if you specify "abort", then no data is inserted if a +record that has to be inserted would trigger an error in GT::SQL::Table. + +This feature can be useful if you want to insert a relation record assuming +that none of the entities that you specify should exist. + +=head2 Deleting data + +Deleting data from a Relation object works using the following pattern: + + . . + . for each row that matches the delete condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . delete the record . + . end-do . + . . + . for each table that is being referenced by another . + . table in the current relation object . + . do . + . delete the record unless there exists . + . some "referencing" data. . + . end-do . + . . + +As I feel that this explanation is probably very confusing, let us see how it +works using our classical example (The salary column has been removed). + + .-------------------------------------------------------------. + | EMPLOYEE.ID | COMPANY_ID | EMPLOYEE.NAME | COMPANY.NAME | + `-------------------------------------------------------------' + | 1 | 1 | Alex | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 2 | 1 | Scott | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 3 | 1 | Aki | Gossamer Threads | + `-------------------------------------------------------------' + +Now let us say that we do the following: + + # remove all the crazy geeks + $relation->delete({ 'EMPLOYEE.NAME' => 'Scott' }); + +This will remove "Scott" from the EMPLOYEE table, but of course +Gossamer Threads will not be deleted because there still exists Alex and Aki +that would reference it. + +Now if we do: + + $relation->delete({ 'COMPANY.NAME' => 'Gossamer Threads' }); + +or even + + my $condition = new GT::SQL::Condition; + $condition->add(qw/EMPLOYEE.NAME LIKE %/); + $relation->delete($condition); + +Then we have generated a condition that matches all the employees, this means +that when the last record will be deleted, then the company Gossamer Threads +will have no more employees and therefore will be deleted. + +(Yeah, well, this is for the purpose of this example, of course this will never +happen in real life :) ) + +=head2 Updating records + +Currently, there exists a limitation on updating records in a Relation, which +is that only the records that represent the "many" part of the Relation are +updated. + +The way it proceeds to perform the update is pretty simple: + + . . + . for each row that matches the update condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . update the record . + . end-do . + . . + +That means that this will work: + + # SALARY being a property of EMPLOYEE, it will be updated + # because EMPLOYEE references COMPANY and therefore is a + # "many" + $relation->update({ SALARY => $big_bill }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + + # nope, you cannot use Relation to update the COMPANY table that + # way, this will not do anything. + $relation->update({ 'COMPANY.NAME' => 'New_Name' }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + +Who would like to change such a great name anyway ? + +=head2 Selecting Records + +Select behaves exactly like L select. The only difference is +the ability to specify LEFT JOINs. For instance, if you want to see a list of +Employees who don't belong to a company, you can do: + + my $relation = $DB->table('Employees', 'Company'); + my $cond = GT::SQL::Condition->new('Company.ID', 'IS', \'NULL'); + my $sth = $relation->select('left_join', $cond); + +The order of tables specified in the relation constructor is important! + +In selecting columns, calling functions utilizing fully qualified column names +will cause GT::SQL::Relation to fail. Simply turn the values into references +like below. + + my $sth = $relation->select("MIN(Company.ID)"); # will fail + + my $sth = $relation->select(\"MIN(Company.ID)"); # will work + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Search.pm b/site/glist/lib/GT/SQL/Search.pm new file mode 100644 index 0000000..39588d9 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search.pm @@ -0,0 +1,584 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search +# Author : Aki Mimoto +# CVS Info : +# $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# highlevel class for searching, works with GT::SQL::Indexer +# + +package GT::SQL::Search; +#-------------------------------------------------------------------------------- + +# pragmas +use strict; +use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/; + +# includes +use GT::Base; +use GT::AutoLoader; + +# variables +$VERSION = sprintf "%d.%03d", q$Revision: 1.60 $ =~ /(\d+)\.(\d+)/; +@ISA = qw(GT::Base); +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + UNKNOWNDRIVER => 'Unknown driver requested: %s', + NOTABLE => 'Cannot find reference to table object' +}; + +sub load_search { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Search'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Search"; + return $pkg->load(@_); +} + +sub load_indexer { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Indexer'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Indexer"; + + return $pkg->load(@_); +} + +sub driver_ok { +#-------------------------------------------------------------------------------- +# checks to see if a particular driver is allowed on this system +# + my $class = shift; + my $driver = uc shift or return; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $mode = $opts->{mode} || 'Indexer'; + my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' ); + my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode; + + eval { require "GT/SQL/Search/$driver/$mode.pm" }; + $@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver); + return $pkg->can('ok') ? $pkg->ok($tbl) : 1; +} + +sub load_driver { +#-------------------------------------------------------------------------------- +# Loads a driver into memory. +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $tbl = $opts->{table}; + my $mode = $opts->{mode} || 'Indexer'; + my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED'); + + require "GT/SQL/Search/$driver/$mode.pm"; + return $driver; +} + +sub available_drivers { +#-------------------------------------------------------------------------------- +# Returns a list of available drivers. +# + my $class = shift; + + (my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//; + opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!"); + my @arr; + for my $driver_name (readdir DHANDLE) { + next if $driver_name =~ y/a-z//; + -f "$path/$driver_name/Search.pm" and -r _ or next; + -f "$path/$driver_name/Indexer.pm" and -r _ or next; + my $loaded = eval { + require "GT/SQL/Search/$driver_name/Search.pm"; + require "GT/SQL/Search/$driver_name/Indexer.pm"; + }; + push @arr, $driver_name if $loaded; + } + closedir DHANDLE; + return wantarray ? @arr : \@arr; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Search - internal driver for searching + +=head1 SYNOPSIS + +This implements the query string based searching scheme for GT::SQL. Driver +based, it is designed to take advantage of the different indexing schemes +available on different database engines. + +=head1 DESCRIPTION + +Instead of describing how Search.pm is interfaced* this will describe how a +driver should be structured and how a new driver can be implemented. + +* as it is never accessed directly by the programmer as it was designed to be +called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth + +=head2 Drivers + +A driver has two parts. The Indexer and the Search packages are the most +important. Howserver, for any driver in the search, there must exist a directory +with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES +for Postgres. Within each driver directory, The Indexer and Search portions of +the driver contains all the information required for initializing the database +table and searching the database. + +The Indexing package of the driver handles all the data that is manipulated in +the database and also the initializes and the database for indexing. + +The Search package handles the queries and retrieves results for the eventual +consumption by the calling program. + +Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base +and operate by overriding certain key functions. + +The next few sections will cover how to create a search driver, and assumes a +fair bit of familiarity with GT::SQL. + +=head2 Structure of an Indexing Driver + +The following is an absolutely simple skeleton driver that does nothing and but +called "CUSTOM". Found in the CUSTOM directory, this is the search package, and +would be call Search.pm in the GT/SQL/Search/CUSTOM library directory. + + package GT::SQL::Search::CUSTOM::Search; + #------------------------------------------ + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) }; + + # overrides would go here + + 1; + +For the indexer, another file, Indexer.pm would be found in the +GT/SQL/Search/CUSTOM directory. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + + # overrides would go here + + 1; + +The almost empty subs that immediately return with a value are functions that +can be overridden to do special tasks. More will be detailed later. + +The Driver has been split into two packages. The original package name, +GT::SQL::Search::Nothing, houses the Search package. +GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system. +"::Indexer" must be appended to the orginial search name for the indexer. + +Each of the override functions are triggered at points just before and after a +major event occurs in GT::SQL. Depending on the type of actions you require, you +pick and chose which events you'd like your driver to attach to. + +=head2 Structure of Indexing Driver + +The Indexer is responsible for creating all the indexes, maintaining them and +when the table is dropped, removing all the associated indexes. + +The following header must be defined for the Indexer. +GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::Base; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +In addition to the header, the following function must be defined. +GT::SQL::Search::Driver::Indexer::load creates the new object and allows for +special preinitialization that must occur. You can also create another driver +silently (such as defaulting to INTERNAL after a version check fails). + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + +Finally, there are the overrides. None of the override functions need be defined +in your driver. Any calls made to undefined methods will silently fallback to +the superclass driver's methods. When a method has been overridden, the function +must return a true value when it is successful, otherwise the action will fail +and an error generated. + +Whenever a object is created it will receive one property $self->{table} which +is the table that is being worked upon. This property is available in all the +method calls and is required for methods such as _create_table and +_drop_search_driver methods. + +When a table is first created or when a table is destroyed the following two +functions are called. They are not passed any special values, however, these are +all class methods and $self->{table} will be a reference to the current table in +use. + +This set of overrides are used by GT::SQL::Creator when the ::create method is +called. They are called just prior and then after the create table sql query has +been executed. + +=over 2 + +=item pre_create_table + +=item post_create_table + +These functions receive no special parameters. They will receive the data to the +table in the $self->{table} property. + +=back + +This next set of functions take place in GT::SQL::Editor. + +=over 2 + +=item drop_search_driver + +This method receives no special parameters but is responsible for removing all +indexes and "things" associated with the indexing schema. + +=item add_search_driver + +Receives no extra parameters. Creates all indexes and does all actions required +to initialize indexing scheme. + +=item pre_add_column + +=item post_add_column + +The previous two functions are called just before and after a new column is +added. + +pre_add_column accepts $name (of column), $col (hashref of column attributes). +The method will only be called if the column has a weight associated with it. +The function must return a non-zero value if successful. Note that the returned +value will be passed into the post_add_column so temporary values can be passed +through if required. + +post_add_column accepts $name (of column), $col (hashref of column attributes), +$results (of pre_add_column). This method is called just after the column has +been inserted into the database. + +=item pre_delete_column + +=item post_delete_column + +These previous functions are called just before and after the sql for a old +column is deleted. They must remove all objects and "things" associated with a +particular column's index. + +pre_delete_column accepts $name (of column), $col (hashref of column +attributes). The method will only be called if the column has a weight +associated with it. The function must return a non-zero value if successful. +Note that the returned value will be passed into the post_delete_column so +temporary values can be passed through if required. + +post_delete_column accepts $name (of column), $col (hashref of column +attributes), $results (of pre_add_column). This method is called just after the +column has been dropped from the database. + +=item pre_drop_table + +=item post_drop_table + +The two previous methods are used before and after the table is dropped. The +methods must remove any tables or "things" related to indexing from the table. + +pre_drop_table receives no arguments. It can find a copy of the current table +and columns associated in $self->{table}. + +post_drop_table receives one argument, which is the result of the +pre_drop_table. + +=back + +The following set of functions take place in GT::SQL::Table + +=over 2 + +=item pre_add_record + +=item post_add_record + +Called just before and after an insert occurs. These functions take the record +and indexes them as required. + +pre_add_record will receive one argument, $rec, hashref, which is the record +that will be inserted into the database. Table information can be found by +accessing $self->{table} Much like the other functions, on success the result +will be cached and fed into the post_add_record function. + +post_add_record receives $rec, a hashref to describing the new result, the $sth +of the insert query, and the result of the pre_add_record method. The result +from $sth->insert_id if there is a ai field will be the new unique primary key. + +=item pre_update_record + +=item post_update_record + +Intercepts the update request before and just after the sql query is executed. +This override has the potential of being rather messy. More than one record can +be modified in this action and the indexer must work a lot to ensure the +database is up to snuff. + +pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is +a hashref containing the new values that must be set, and $where_cond is a +GT::SQL::Condition object selecting records to update. The result once again, is +cached and if undef is considered an error. + +post_update_record takes the same parameters as pre_update_record, except one +extra paremeter, the result of pre_update_record. + +=item pre_delete_record + +=item post_delete_record + +Called just before and after the deletion request for records are called. + +pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object +telling which records to delete. The results of this method are passed to +post_delete_record. + +post_delete_record, has one addition parameter to pre_delete_record and like +most post_ methods, is the result of the pre_delete_record method. + +=item pre_delete_all_records + +=item post_delete_all_records + +These two functions are quite simple, but they are different from drop search +driver in that though the records are all dropped, the framework for all the +indexing is not dropped as well. + +Neither function is passed any special data, except for post_delete_all_records +which receives the rsults of the pre_delete_all_records method. + +=item reindex_all + +This function is sometimes called by the user to refresh the index. The +motivation for this, in the case of the INTERNAL driver, is sometimes due to +outside manipulation of the database tables, the index can become +non-representative of the data in the tables. This method is to force the +indexing system to fix errors that have passed. + +=item ok + +This function is called by GT::SQL::Search as a package method, +GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object +reference. What this function must do is to return a true or false value that +tells the search system if this driver can be used. The MYSQL driver has a good +example for this, it tests to ensure that the mysql database system version is +at least 3.23.23. + +=back + +=head2 Structure of a Search Driver + +The Searcher is responsible for only one thing, to return results from a query +search. You can override the parser, however, subclassing the following methods +will have full parsing for all things such as +/-, string parsing and substring +matching. + +The structures passed into the methods get a little complicated so beware! + +ALL the following functions receive two parameters, the first is a search +parameters detailing the words/phrases to search for, the second parameter is +the current result set of IDs => scores. + +There are two types of search parameters, one for words and the other for +phrases. The structure is a little messy so I'll detail them here. + +For words, the structure is like the following: + + $word_search = { + 'word' => { + substring => '1', # set to 1 if this is substring match + phrase => 0, # not a phrase + keyword => 1, # is a keyword + mode => '', # can also be must, cannot to mean +/- + }, + 'word2' => ... + } + +For phrases the structure will become: + + $phrase_search => { + 'phrase' => { + substring => undef # never required + phrase => [ + 'word1', + 'word2', + 'word3', + ... + ], # for searching by indiv word if required + keyword => 0, # not a keyword + mode => '' # can also be must, cannot + }, + 'phrase2' => ... + } + +Based on these structures, hopefully it will be easy enough to build whatever is +required to grab the appropriate records. + +Finally, the second item passed in will be a hash filled with ID => score values +of search results. They look something like this: + + $results = { + 1 => 56, + 2 => 31, + 4 => 6 + } + +It is important for all the methods to take the results and return the results, +as the result set will be daisychained down like a set to be operated on by +various searching schemes. + +At the end of the query, the results in this set will be sorted and returned to +the user as an sth. + +Operations on this set are preformed by the following five methods. + +=over 2 + +=item _query + +This method is called just after all the query string has been parsed and put +into their proper buckets. This method is overridden by the INTERNAL driver to +decide it wants to switch to the NONINDEX driver for better performance. + +Two parameters are passed in, ( $input, $buckets ). $input is a hash that +contains all the form/cgi parameters passed to the $tbl->query function and +$buckets is s the structure that is created after the query string is parsed. +You may also call $self->SUPER::_query( $input, $buckets ) to pass the request +along normally. + +You must return undef or an STH from this function. + +=item _union_query + +This method takes a $word_search and does a simple match query. If it finds +records with any of the words included, it will append the results to the list. +Passed in is the $results and it must return the altered results set. + +This method must also implement substring searching. + +=item _phrase_query + +Just like the union_query, however it searches based on phrases. + +=item _phrase_intersect_query + +This takes a $phrase_search and a $result as parameters. This method must look +to find results that are found within the current result set that have the +passed phrases as well. However, if there are no results found, this method can +look for more results. + +=item _intersect_query + +Takes two parameters, a $word_search, and $results. Just like the +_phrase_intersect query, if there are results already, tries to whittle away the +result set. If there are no results, tries to look for results that have all the +keywords in a record. + +This method must also implement substring searching. + +=item _disjoin_query + +Takes two parameters, a $word_search, and $results. This will look through the +result set and remove all matches to any of the keywords. + +This method must also implement substring searching. + +=item _phrase_disjoin_query + +Two parameters, $phrase_search and $results are passed to this method. This does +the exact same thing as _disjoin_query but it looks for phrases. + +=item query + +If you choose to override this method, you will have full control of the query. + +This method accepts a $CGI or a $HASH object and performs the following + + Options: + - paging + mh : max hits + nh : number hit (or page of hits) + sb : column to sort by (default is by score) + + - searching + ww : whole word + ma : 1 => OR match, 0 => AND match, undefined => QUERY + substring : search for substrings of words + bool : 'and' => and search, 'or' => or search, '' => regular query + query : the string of things to ask for + + - filtering + field_name : value # Find all rows with field_name = value + field_name : ">value" # Find all rows with field_name > value. + field_name : " value. + field_name-lt : value # Find all rows with field_name < value. + +The function must return a STH object. However, you may find useful the +GT::SQL::Search::STH object, which will automatically handle mh, nh, and +alternative sorting requests. All you will have to do is + + sub query { ... your code ... return $self->sth( $results ); } + +Where results is a hashref containing primarykeyvalue => scorevalues. + +=item alternate_driver_query + +There is no reason to override this method, however, if you would like to use +another driver's search instead of the current, this method will let you do so. + +Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name +of the driver you'd like to use and $input is the parameters passed to the +method. Returned is an $sth value (undef if an error has occured). This method +was used in the INTERNAL driver to shunt to NONINDEXED if it found the search +would take too long. + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Search/Base/Common.pm b/site/glist/lib/GT/SQL/Search/Base/Common.pm new file mode 100644 index 0000000..e2a0cbe --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/Base/Common.pm @@ -0,0 +1,82 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Common +# Author : Aki Mimoto +# CVS Info : +# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# +package GT::SQL::Search::Base::Common; + +use strict; +use Exporter; +use vars qw/ @ISA @EXPORT $STOPWORDS /; + + @ISA = qw( Exporter ); + @EXPORT = qw( &_tokenize &_check_word $STOPWORDS ); + + $STOPWORDS = { map { $_ => 1 } qw/ + of about or all several also she among since an some and such are than + as that at the be them because there been these between they both this + but those by to do toward during towards each upon either for from was + had were has what have when he where her which his while however with if + within in would into you your is it its many more most must on re it + test not above add am pm jan january feb february mar march apr april + may jun june jul july aug august sep sept september oct october nov + november dec december find & > < we http com www inc other + including + / }; + +sub _tokenize { +#-------------------------------------------------------------------------------- +# takes a strings and chops it up into little bits + my $self = shift; + my $text = shift; + my ( @words, $i, %rejected, $word, $code ); + +# split on any non-word (includes accents) characters + @words = split /[^\w\x80-\xFF\-]+/, lc $text; + $self->debug_dumper( "Words: ", \@words ) if ($self->{_debug}); + +# drop all words that are too small, etc. + $i = 0; + while ( $i <= $#words ) { + $word = $words[ $i ]; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + splice( @words, $i, 1 ); + $rejected{$word} = $self->{'rejections'}->{$code}; + } + else { + $i++; # Words ok. + } + } + $self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug}); + $self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug}); + + return ( \@words, \%rejected ); +} + +sub _check_word { +#-------------------------------------------------------------------------------- +# Returns an error code if it is an invalid word, otherwise returns nothing. +# + my $self = shift; + my $word = shift; + my $code; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + return $code; + } + return; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/Base/Indexer.pm b/site/glist/lib/GT/SQL/Search/Base/Indexer.pm new file mode 100644 index 0000000..c796485 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/Base/Indexer.pm @@ -0,0 +1,78 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Indexer +# Author: Aki Mimoto +# CVS Info : +# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# +# + +package GT::SQL::Search::Base::Indexer; + + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/GT::Base GT::SQL::Search::Base::Common/; + $ATTRIBS = { + driver => undef, + stopwords => $STOPWORDS, + rejections => { + STOPWORD => "is a stopword", + TOOSMALL => "is too small a word", + TOOBIG => "is too big a word" + }, + table => '', + init => 0, + debug => 0, + min_word_size => 3, + max_word_size => 50, + }; + +sub drop_search_driver { 1 } +sub add_search_driver { 1 } + +# found in GT::SQL::Creator +sub pre_create_table { 1 } +sub post_create_table { 1 } + +# GT::SQL::Editor +sub pre_add_column { 1 } +sub post_add_column { 1 } + +sub pre_delete_column { 1 } +sub post_delete_column { 1 } + +sub pre_drop_table { 1 } +sub post_drop_table { 1 } + +# GT::SQL::Table +sub pre_add_record { 1 } +sub post_add_record { 1 } + +sub pre_update_record { 1 } +sub post_update_record { 1 } + +sub pre_delete_record { 1 } +sub post_delete_record { 1 } + +sub pre_delete_all_records { 1 } +sub post_delete_all_records { 1 } + +sub driver_ok { 1 } + +sub reindex_all { 1 } + +1; diff --git a/site/glist/lib/GT/SQL/Search/Base/STH.pm b/site/glist/lib/GT/SQL/Search/Base/STH.pm new file mode 100644 index 0000000..c0746cf --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/Base/STH.pm @@ -0,0 +1,287 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::STH +# Author: Aki Mimoto +# CVS Info : +# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::STH; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /; + use GT::Base; + + @ISA = ('GT::Base'); + $ATTRIBS = { + '_debug' => 0, + 'sth' => undef, + 'results' => {}, + 'db' => undef, + 'table' => undef, + 'index' => 0, + 'order' => [], + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'nh' => 0, + 'mh' => 0 + }; + $ERROR_MESSAGE = 'GT::SQL'; + $ERRORS = { + BADSB => 'Invalid character found in so: "%s"', + }; + +sub init { +#-------------------------------------------------------------------------------- + my $self = shift; + +# setup the options + $self->set(@_); + +# correct a few of the values + --$self->{nh} if $self->{nh}; + + my $sth; + my $results = $self->{results}; + $self->{rows} = scalar( $results ? keys %{$results} : 0 ); + +# if we have asked to have sorting by another column (non score), create the part of the query that handles taht + $self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug}); + my $sb; + +# clean up the sort by columns. + unless ($self->{'score_sort'}) { + $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so}); + } + +# setup the max hits and the offsets + $self->{index} = $self->{nh} * $self->{mh} || 0; + $self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned. + + if ( $self->{max_index} > $self->{rows} ) { + $self->{max_index} = $self->{rows}; + $self->{rows} = $self->{rows} - $self->{index}; + $self->{rows} < 0 ? $self->{rows} = 0 : 0; + } + + else { + $self->{rows} = $self->{mh}; + } + +# if we are sorting by another column, handle that + if ( $sb and (keys %{$self->{results}})) { + my ( $table, $pk ) = $self->_table_info(); + my ( $query, $where, $st, $limit ); + + $where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')'; + $self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!; + $query = qq! + SELECT $pk + FROM $table + WHERE $where + $sb + $limit + !; + $self->debug( "Row fetch query: $query" ) if ($self->{_debug}); + $sth = $self->{table}->{driver}->prepare( $query ); + $sth->execute(); + +# fix the counts + $self->{index} = 0; + $self->{max_hits} = $self->{rows}; + +# now return them + my $order = $sth->fetchall_arrayref(); + $sth->finish(); + + $self->{'order'} = [ map { $_->[0] } @{$order} ]; + } + else { + $self->{'order'} = [ sort { + ( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 ) + } keys %{$results} ]; + $self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug}); + } + +} + +sub cache_results { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my ($sth, @records, $i, %horder, @order, $in_list); + my $table = $self->{table}; + my $tname = $table->name(); + my ($pk) = $self->{table}->pk; + + use GT::SQL::Condition; + +# we know what we're doing here so shut off warns (complains about uninit'd values in range +# if thee aren't enough elements in the order array) + my $w = $^W; $^W = 0; + @order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return []; + $^W = $w; + + $i = 0; %horder = ( map { ( $_ => $i++) } @order ); + $in_list = join ( ",", @order ); + my $query = qq| + SELECT * + FROM + $tname + WHERE + $pk IN($in_list) + |; + +# the following is left commented out as... +# if $tbl->select is used $table->hits() will not +# return an accurate count of the number of all the hits. instead, will return +# a value up to mh. $tbl->hits() is important because the value is used +# in toolbar calculations +# +# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) ); + $sth = $table->do_query( $query ); + + while ( my $href = $sth->fetchrow_hashref() ) { + $records[$horder{$href->{$pk}}] = \%$href + } + + return \@records; + +} + +sub fetchrow_array { +#-------------------------------------------------------------------------------- + return @{ $_[0]->fetchrow_arrayref() || [] }; +} + +sub fetchrow_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + my $records = $self->{cache} ||= $self->cache_results; + my $href = shift @$records or return; + return $self->_hash_to_array($href); +} + +sub fetchrow_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my $records = $self->{cache} ||= $self->cache_results; + my $table = $self->{table}; + my ($pk) = $self->{table}->pk; + + my $href = shift @$records or return; + + $href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} ); + + return $href; + +} + +sub fetchall_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + my @results; + while (my $res = $self->fetchrow_hashref) { + push @results, $res; + } + return \@results; +} + +sub fetchall_list { +#-------------------------------------------------------------------------------- + return { map { @$_ } @{shift->fetchall_arrayref} } +} + +sub fetchall_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + + $self->{order} or return []; + my $results = $self->{results}; + my ($pk) = $self->{table}->pk; + my $scol = $self->{score_col}; + + + if (!$self->{allref_cache}) { + $self->{allref_cache} ||= $self->cache_results; + + for my $i ( 0 .. $#{$self->{allref_cache}} ) { + my $element = $self->{allref_cache}->[$i]; + if ( $_[0] eq 'HASH' ) { + $element->{$scol} = $results->{$element->{$pk}}; + } + else { + $element->{$scol} = $self->_hash_to_array( $element->{$scol} ); + } + }; + } + + my $records = $self->{allref_cache}; + + return $records; +} + +sub score { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{score}; +} + +sub _hash_to_array { +#-------------------------------------------------------------------------------- + my $self = shift; + my $href = shift or return; + + my $results = $self->{'results'}; + my $table = $self->{table}; + my $cols = $table->cols(); + my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] ); + my ($pk) = $self->{table}->pk; + my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ]; + + return $aref; +} + +sub rows { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{rows}; +} + +sub _table_info { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my ($pk) = $self->{table}->pk; + return ( $table, $pk ); +} + +sub DESTROY { +#-------------------------------------------------------------------------------- + my $self = shift; + $self->{'sth'} and $self->{'sth'}->finish(); +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/Base/Search.pm b/site/glist/lib/GT/SQL/Search/Base/Search.pm new file mode 100644 index 0000000..991097b --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/Base/Search.pm @@ -0,0 +1,572 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base +# Author : Aki Mimoto +# CVS Info : +# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# + +package GT::SQL::Search::Base::Search; + + + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + @ISA = qw( GT::Base GT::SQL::Search::Base::Common); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/ GT::Base /; + + $ATTRIBS = { + 'stopwords' => $STOPWORDS, + 'mh' => 25, + 'nh' => 1, + 'ww' => undef, + 'ma' => undef, + 'bool' => undef, + 'substring' => 0, + 'query' => '', + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'debug' => 0, + '_debug' => 0, + +# query related + 'db' => undef, + 'table' => undef, + 'filter' => undef, + 'callback' => undef, + +# strict matching of indexed words, accents on words do count + 'sm' => 0, + 'min_word_size' => 3, + 'max_word_size' => 50, + }; + +sub init { +#-------------------------------------------------------------------------------- +# Initialises the Search object +# + my $self = shift; + my $input = $self->common_param(@_); + + $self->set($input); + +# now handle filters..., + my $tbl = $self->{table}; + my $cols = $tbl->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + exists $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if ( keys %filters ) { + $self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} ); + $self->filter(\%filters); + } + + $self->{table}->connect; +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query..., + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{'rejected_keywords'} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = &_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + return $self->_query($input, $buckets); +} + +sub _query { +#-------------------------------------------------------------------------------- + my ( $self, $input, $buckets ) = @_; + +# now handle the separate possibilities + my $results = {}; + +# query can have phrases + $results = $self->_phrase_query( $buckets->{phrases}, $results ); + $self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query have keywords + $results = $self->_union_query( $buckets->{keywords}, $results ); + $self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have phrases + $results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results ); + $self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have keywords + $results = $self->_intersect_query( $buckets->{keywords_must}, $results ); + $self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have keywords + $results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results ); + $self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have phrases + $results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results); + $self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $results = $self->filter(\%filters, $results); + } + elsif ($self->{filter}) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $results = $self->_filter_query( $self->{filter}, $results ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll dothat here + $self->{filter} = undef; + +# now run through a callback function if needed. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + $self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + } + +# so how many hits did we get? + $self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) ); + +# and now create a search sth object to handle all this + return $self->sth( $results ); +} + +sub sth { +#-------------------------------------------------------------------------------- + my $self = shift; + my $results = shift; + + require GT::SQL::Search::Base::STH; + my $sth = GT::SQL::Search::STH->new( + 'results' => $results, + 'db' => $self->{table}->{driver}, +# pass the following attributes down to the STH handler + map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /) + ); + + return $sth; +} + +sub rows { +#-------------------------------------------------------------------------------- +# after a query is run, returns the number of rows + my $self = shift; + return $self->{rows} || 0; +} + +sub _add_filters { +#-------------------------------------------------------------------------------- +# creates the filter object + my $self = shift; + my $filter; + +# find out how we're calling the parameters + if ( ref $_[0] eq 'GT::SQL::Condition' ) { + $filter = shift; + } + elsif ( ref $_[0] eq 'HASH' ) { + + +# setup the query condition using the build_query condition method +# build the condition object + my %opts = %{ shift() || {} }; + delete $opts{query}; + + $filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} ); + + } + else { + return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter"); + } + +# Use ref, as someone can pass in filter => 1 and mess things up. + + ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter); + $self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug}); + + return $self->{filter}; + +} + +sub _preset_options { +#-------------------------------------------------------------------------------- +# sets up word parameters + my $self = shift; + my $query = shift or return; + my $input = shift or return $query; + +# whole word searching + if ( defined $input->{'ww'} or defined $self->{'ww'}) { + if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; } + } + } + +# substring searching + if ( defined $input->{'substring'} or defined $self->{'substring'}) { + if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) { + for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; } + } + } + + if ( defined $input->{'ma'} or defined $self->{'ma'} ) { +# each keyword must be included + if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } +# each word can be included but is not necessary + else { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + +# some more and or searches, only if user hasn't put +word -word + if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } + } + elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + + return $query; +} + +sub _phrase_query { $_[1] } +sub _union_query { $_[1] } +sub _phrase_intersect_query { $_[1] } +sub _intersect_query { $_[1] } +sub _disjoin_query { $_[1] } +sub _phrase_disjoin_query { $_[1] } + +sub filter { +#-------------------------------------------------------------------------------- +# adds a filter +# + my $self = shift; + +# add filters.., + my $filters = $self->_add_filters( shift ); + my $results = shift; + +# see if we need to execute a search, otherwise just return the current filterset + defined $results or return $results; + +# start doing the filter stuff + return $self->_filter_query( $filters, $results ); +} + +sub _parse_query_string { +#------------------------------------------------------------ +# from Mastering Regular Expressions altered a fair bit +# takes a space delimited string and breaks it up. +# + my $self = shift; + my $text = shift; + + my %words = (); + my %reject = (); + my %mode = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# work on the individual elements + my @new = (); + while ( $text =~ m{ + # the first part groups the phrase inside the quotes. + # see explanation of this pattern in MRE + ([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ? + | (\+?[\w\x80-\xFF\-\*]+),? + | ' ' + }gx ) { + + my $match = lc $+; + +# strip out buffering spaces + $match =~ s/^\s+//; $match =~ s/\s+$//; + +# don't bother trying if there is nothing there + next unless $match; + +# find out the searching mode + my ($mode, $substring, $phrase); + if (my $m = $mode{substr($match,0,1)}) { + $match = substr($match,1); + $mode = $m; + } + +# do we need to substring match? + if ( substr( $match, -1, 1 ) eq "*" ) { + $match = substr($match,0,length($match)-1); + $substring = 1; + } + +# find out if we're dealing with a phrase + if ( substr($match,0,1) eq '"' ) { + $self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug}); + + $match = substr($match,1); + +# however, we want to make sure it's a phrase and not something else + my ( $word_list, $rejected ) = $self->_tokenize( $match ); + $self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug}); + $self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug}); + my $word_count = @$word_list; + + if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase + elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase + } + +# make sure we can use this word + if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) { + $reject{ $match } = $code; + next; + } + +# now, see if we should toss this word + $words{$match} = { + mode => $mode, + phrase => $phrase, + substring => $substring, + keyword => not $phrase, + }; + } + +# words is a hashref of: +# { +# word => { +# paramaters => 'values' +# }, +# word1 => { +# ... +# }, +# ... +# } +# + return( \%words, \%reject ); + +} + + +sub _filter_query { +#-------------------------------------------------------------------------------- +# get the results from the filter +# + my $self = shift; + my $filters = shift; + my $results = shift or return {}; + keys %{$results} or return $results; + + my $table = $self->{table}; + my $tname = $table->name(); + +# setup the where clause + my $where = $filters->sql() or return $results; + my ($pk) = $table->pk; + $where .= qq! AND $pk IN (! . join(',', keys %$results) . ')'; + +# now do the filter + my $query = qq! + SELECT $pk + FROM + $tname + WHERE + $where + !; + $self->debug( "Filter Query: $query" ) if ($self->{_debug}); + my $sth = $self->{table}->{driver}->prepare($query); + $sth->execute(); + +# get all the results + my $aref = $sth->fetchall_arrayref; + return { + map { + $_->[0] => $results->{$_->[0]} + } @$aref + }; +} + +sub _create_buckets { +#------------------------------------------------------------ +# takes the output from _parse_query_string and creates a +# bucket hash of all the different types of searching +# possible + my $query = shift or return; + + my %buckets; + +# put each word in the appropriate hash bucket + foreach my $parameter ( keys %{$query} ) { + + my $word_data = $query->{$parameter}; + +# the following is slower, however, done that way to be syntatically legible + if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) { + $buckets{"phrases_$1"}->{$parameter} = $word_data; + } + elsif ( $word_data->{'phrase'} ) { + $buckets{'phrases'}->{$parameter} = $word_data; + } + elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) { + $buckets{"keywords_$1"}->{$parameter} = $word_data; + } + else { + $buckets{'keywords'}->{$parameter} = $word_data; + } + + } + + return \%buckets; +} + +sub alternate_driver_query { +#-------------------------------------------------------------------------------- + my ( $self, $drivername, $input ) = @_; + + $drivername = uc $drivername; + require GT::SQL::Search; + my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername }); + my $sth = $driver->query( $input ); + foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; } + return $sth; + +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + +# Remove score attribute, used only for internal indexes. + $sb =~ s/^\s*score\b//; + $sb =~ s/,?\s*\bscore\b//; + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm b/site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm new file mode 100644 index 0000000..65af84f --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm @@ -0,0 +1,411 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::INTERNAL::Indexer +# Author: Aki Mimoto +# CVS Info : +# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::INTERNAL::Indexer; + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Indexer->new(@_) +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $table = $self->{table}->name; + my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List"); + my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List"); + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $name = $self->{table}->name; + +# first create the table that handles the words. + my $creator = $self->{table}->creator ( $name . "_Word_List" ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Word => { + pos => 2, + type => 'varchar', + not_null=> 1, + size => '50' + }, + Frequency => { + pos => 3, + type => 'int', + not_null=> 1 + } + ); + $creator->pk('Word_ID'); + $creator->ai('Word_ID'); + $creator->unique({ $name . "_wordndx" => ['Word'] }); + $creator->create('force') or return; + +# now create the handler for scores + $creator = $self->{table}->creator( $name . '_Score_List' ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Item_ID => { + pos => 2, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Score => { + pos => 3, + type => 'int', + not_null => 1 + }, + Word_Pos => { + pos => 4, + type => 'int', + not_null => 1 + } + ); + $creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] }); + $creator->create('force') or return; + return 1; + +} + +sub post_create_table { +# ------------------------------------------------------------------------------ +# creates the index tables.. +# + return $_[0]->add_search_driver(@_); +} + +sub post_drop_table { +# ------------------------------------------------------- +# Remove the index tables. +# + return $_[0]->drop_search_driver(@_); +} + +sub init_queries { +# ------------------------------------------------------- +# Pre-load all our queries. +# + my $self = shift; + my $queries = shift; + + my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL'); + my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table_name . '_Word_List'; + my $seq = $wtable . '_seq'; + my $stable = $table_name . '_Score_List'; + + my %ai_queries = ( + ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)", + ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)", + ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)" + ); + my %queries = ( + upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?", + sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?", + sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?", + del_word => "DELETE FROM $wtable WHERE Word_ID = ?", + mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?", + ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)", + item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID", + scr_del => "DELETE FROM $stable WHERE Item_ID = ?", + dump_word => "DELETE FROM $wtable", + dump_scor => "DELETE FROM $stable" + ); + my $type = uc $self->{table}->{connect}->{driver}; + $self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"}); + +# check to see if the table exist + $self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + $self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + + + if ($type eq 'MYSQL') { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } + else { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } +} + +sub post_add_record { +# ------------------------------------------------------- +# indexes a single record + my ($self, $rec, $insert_sth ) = @_; + +# Only continue if we have weights and a primary key. + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk}; + my $index = 0; + + $self->{init} or $self->init_queries; + +# Go through each column and index it. + foreach my $column ( keys %weights ) { + my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + my $weight = $weights{$column}; + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + + return 1; +} + +sub reindex_all { +# ------------------------------------------------------- + my $self = shift; + my $table = shift; + my $opts = shift; + my $tick = $opts->{tick} || 0; + my $max = $opts->{max} || 5000; + + my %weights = $self->{table}->_weight_cols() or return; + my @weight_list = keys %weights; + my @weight_arr = map { $weights{$_} } @weight_list; + my ($pk) = $self->{table}->pk(); + my $index = 0; + my $word_id = 1; + $self->{init} or $self->init_queries; + +# first nuke the current index + $self->dump_index(); + +# Go through the table and index each field. + my $iterations = 1; + my $count = 0; + + while (1) { + if ($max) { + my $offset = ($iterations-1) * $max; + $table->select_options ( "LIMIT $offset,$max"); + } + my $cond = $opts->{cond} || {}; + my $sth = $table->select($cond, [ $pk, @weight_list] ); + my $done = 1; + + while ( my $arrayref = $sth->fetchrow_arrayref() ) { +# the primary key value + my $i = 0; + my $item_id = $arrayref->[($i++)]; + $index = 0; + $done = 0; + +# start going through the record data + foreach my $weight ( @weight_arr ) { + my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + if ($tick) { + $count++; + $count % $tick or (print "$count "); + $count % ($tick*10) or (print "\n"); + } + } + return if ($done); + $iterations++; + return if (! $max); + } +} + +sub pre_delete_record { +# ------------------------------------------------------- +# Delete a records index values. +# + my $self = shift; + my $where = shift; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $q = $tbl->select( $where, [ $pk ] ); + + while ( my $aref = $q->fetchrow_arrayref() ) { + my $item_id = $aref->[0] or next; + my @weight_list = keys %weights; + my $index = 0; + $self->{init} or $self->init_queries; + + # Get a frequency count for each word + $self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + + # Now go through and either decrement the freq, or remove the entry. + while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) { + $self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug}); + if (my $freq = $self->{sel_freq}->fetchrow_arrayref) { + if ($freq->[0] == $frequency) { + $self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + } + } + # Remove the listings from the scores table. + $self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + return 1; +} + +sub post_update_record { +# ------------------------------------------------------- + my ( $self, $set_cond, $where_cond, $tmp ) = @_; + +# delete the previous record + $self->pre_delete_record( $where_cond ) or return; +# +# the new record + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my $q = $tbl->select( $where_cond ); + while ( my $href = $q->fetchrow_hashref() ) { + $self->post_add_record( $href ); + } + + return 1; + +} + +sub reindex_record { +# ------------------------------------------------------- +# reindexes a record. basically deletes all associated records from current db abnd does an index. +# it's safe to use this + my $self = shift; + my $rec = shift; + + $self->delete_record($rec); + $self->index_record($rec); +} + +sub dump_index { +# ------------------------------------------------------- + my $self = shift; + $self->{init} or $self->init_queries; + + $self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); +} + + +sub debug_dumper { +# ------------------------------------------------------------------------------ +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )); + } +} + +sub DESTROY { +# ------------------------------------------------------------------------------ +# Calls finish on init queries. +# + my $self = shift; + return unless ($self->{init}); + $self->{upd_word}->finish; +# $self->{ins_word}->finish; will get finished automatically + $self->{sel_word}->finish; + $self->{sel_freq}->finish; + $self->{del_word}->finish; + $self->{mod_word}->finish; + $self->{ins_scor}->finish; + $self->{item_cnt}->finish; + $self->{scr_del}->finish; + $self->{dump_word}->finish; + $self->{dump_scor}->finish; + $self->{init} = 0; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm b/site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm new file mode 100644 index 0000000..87fe0a0 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm @@ -0,0 +1,604 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Indexer +# Author : Aki Mimoto +# CVS Info : +# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Search::INTERNAL::Search; + +# ------------------------------------------------------------------------------ + use strict; + use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# the max number of links that can be handled by UNION before it should simply +# shunt the searching pipe to NONINDEXED system + 'union_shunt_threshold' => '5000', + 'phrase_shunt_threshold' => '1000', + }; + + +################################################################################ +# Internal functions +################################################################################ + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Search->new(@_) +} + +sub _query { +# ------------------------------------------------------------------------------ +# this just checks to ensure that the words are not all search keywords +# + my ( $self, $input, $buckets ) = @_; + +# calculate wordids and frequencies + foreach ( keys %$buckets ) { + $buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) ); + } + +# the following is a bit tricky and will be replaced however, if the number +# of results from a union is more than the maximum shunt value, it will +# simply do a nonindexed query + if ( $buckets->{keywords} ) { + my $rec = _count_frequencies( $buckets->{keywords} ); + my $count = 0; + foreach ( values %$rec ) { $count += $_; } + if ($count > $self->{union_shunt_threshold}) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + + +# Now test the phrases. Just due to how the phrase searching works, the queries +# can grow in size extremely rapidly, and slowdown the search. So the limit for +# phrase searching is separate as it requires a different cutoff value than +# the keyword search which is usually much lower! + if ($buckets->{phrases}) { + foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + if ($buckets->{phrases_must}) { + foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + return $self->SUPER::_query( $input, $buckets ); +} + +sub _count_frequencies { +# ------------------------------------------------------------------------------ + my $word_info = shift; + my $rec = {}; + foreach my $word ( keys %$word_info ) { + my $freq = 0; + foreach ( values %{$word_info->{$word}->{word_info}} ) { + $freq += $_; + } + $rec->{$word} = $freq; + } + + return $rec; +} + +sub _table_names { +# ------------------------------------------------------------------------------ +# return the table names +# + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table . '_Word_List'; + my $stable = $table . '_Score_List'; + + return ( $table, $wtable, $stable); +} + +sub _word_infos { +# ------------------------------------------------------------------------------ +# get the word ids and frequencies +# + my $self = shift; + my $word_infos = shift; + + my $rec = {}; + + foreach my $word ( keys %$word_infos ) { + my $wi = $word_infos->{$word}->{word_info}; + $rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ]; + } + + return $rec; + +} + +sub _union_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + my ( $query, $where, $db, $word_infos ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return $results; + + return $results unless (keys %{$word_infos}); + + $self->debug_dumper( "Getting words: ", $words) if ($self->{_debug}); + +# build the where clause + my @word_ids; + foreach my $word_synonym_list ( values %$word_infos ) { + next unless ( $word_synonym_list ); + foreach my $word_id ( @{$word_synonym_list }) { + next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference + push @word_ids, $word_id->[0]; # we need to shed the word quantities + } + } + + return $results unless ( @word_ids ); + $where = 'Word_ID IN(' . join(",", @word_ids) . ")"; + +# build the query + $query = qq! + SELECT Item_ID, SUM(Score) + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + + $self->debug( "Union Query: $query" ) if ($self->{_debug}); + +# prepare the query + my $sth = $db->prepare( $query ) or return; + $sth->execute() or return; + +# get the results + my %word_infos = $sth->fetchall_list; + +# merge the current result set into found + foreach my $item ( keys %{$results} ) { + $word_infos{$item} += $results->{$item}; + }; + + return \%word_infos; +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match all the keywords +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + + $words or return $results; + keys %{$words} or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + +# have we left any of our words out? + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return {}; + if ( keys %{$word_infos} < keys %{$words} ) { + return {}; + } + + $self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + + $word_hits->{$word} = $total_freq or return; + + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits}; + + $self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug}); + +# find out how we're going to handle the searching, if the first elements + +################################################################################ +### The following part is for smaller intersect subsets +################################################################################ + my $intersect = $results; + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$intersect} ) { + $where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID, SUM(Score) AS Score + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug( "Intersect Query: $query" ) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + + $self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug}); + +# go through all the matches and intersect them + my %tmp = (); + foreach my $row ( @{$matches} ) { + my ( $itemid, $score ) = @{$row}; + $intersect->{$itemid} ||= 0; + $tmp{ $itemid } = $intersect->{$itemid} + $score; + } + +# inform the system of that development + %tmp or return; + $intersect = \%tmp; + } + + return $intersect; +} + +sub _disjoin_query { +#------------------------------------------------------------ + my $self = shift; + my $words = shift; + my $results = shift || {}; + $words or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $results; + +# have we left any of our words out? + $word_infos = $self->_word_infos( $words ) or return $results; +# if ( keys %{$word_infos} < keys %{$words} ) { +# return $results; +# } + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + my $total_freq = 0; + foreach my $word_synonyms ( $word_infos->{$word} ) { + $total_freq += ( $word_synonyms->[0] || 0 ); + } +# if the value is null this mean there is actually no results, whoops! + $total_freq and $word_hits->{$word} = $total_freq; + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits}; + $self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller disjoin presets +################################################################################ + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$results} ) { + $where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug($query) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + +# strip the matches from the current result set + foreach my $word ( map { $_->[0] } @{$matches}) { + delete $results->{$word}; + } + } + + return $results; +} + +sub _phrase_disjoin_query { +#------------------------------------------------------------ +# subtracts the found phrases from the list + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform disjoin + foreach my $itemid ( keys %{$temp} ) { + $self->debug( "Deleting $itemid from list" ) if ($self->{_debug}); + delete $results->{$itemid}; + } + } + + return $results; +} + +sub _phrase_intersect_query { +#------------------------------------------------------------ +# intersects phrases together + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform intersect + foreach my $itemid ( keys %{$temp} ) { + $temp->{$itemid} += $results->{$itemid} || 0; + } + $results = $temp; + + } + + return $results; + +} + +sub _phrase_query { +#------------------------------------------------------------ +# this is a phrase union query + my $self = shift; + my $phrases = shift or return; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + $results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results ); + } + + return $results; + +} + +sub _get_phrase { +#------------------------------------------------------------ + my $self = shift; + my $wordlist= shift; + my $word_info = shift; + my $results = shift || {}; + + $wordlist or return $results; + + my ( $query, $where, $db, $word_infos, %word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + my ($pk) = $self->{table}->pk; + + $self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug}); + +# get all the word ids that we want to handle + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $word_info ) or return; + + + $self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + @{$word_infos->{$word} || []} or return; + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + +# if the value is null this mean there is actually no results, whoops! + $word_hits{$word} = $total_freq; + } + + $self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug}); + +# so now, setup the order of search + my $i = 0; + my %word_order = map { $_ => $i++ } @{$wordlist}; + my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits; + + $self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller phrases +################################################################################ +# start getting words in order of their frequency + my %matches = (); + my $index = 0; + foreach my $word ( @search_order ) { + +# setup the where clause for the individual words, firstly + if ( keys %matches ) { + my $vector = $word_order{$word} - $index; + $where = '('; + $where = + '(' . + join( + " OR ", + map( + "Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')', + keys %matches + ) + ) . + ") AND "; + } + else { + $where = ''; + } + + $where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')'; + + $query = qq! + SELECT + Item_ID, Score, Word_Pos + FROM + $stable + WHERE + $where + !; + + $self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug}); + my $sth = $db->prepare( $query ); + $sth->execute(); + + %matches = (); + + while (my $hit = $sth->fetchrow_arrayref) { + push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ]; + } + +# If there are no values stored in %matches, it means that for +# this keyword, there have been no hits based upon position. +# In that case, terminate and return a null result + keys %matches or last; + +# where were we in the string? + $index = $word_order{$word}; + } + +# now tally up all the scores and merge the new records in + foreach my $itemid ( keys %matches ) { + my $score = 0; + foreach my $sub_total ( @{$matches{$itemid}} ) { + $score += $sub_total->[1]; + } + $results->{$itemid} += $score; + } + + return $results; +} + +sub get_wordids { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $elements = shift or return; + my $mode = lc shift || 'keywords'; + + if ( $mode eq 'keywords' ) { + $elements = $self->_get_wordid($elements); + } + else { + foreach my $phrase ( keys %$elements ) { + my $results = $self->_get_wordid({ + map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}} + }); + + $elements->{$phrase}->{word_info} = $results; + } + } + + return $elements; +} + +sub _get_wordid { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $words = shift; + my $tbl = $self->{table}; + + my ( $table, $wtable, $stable) = $self->_table_names(); + + foreach my $word ( keys %$words ) { + my $query = + qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! . + quotemeta($word) . + ( $words->{$word}->{substring} ? '%' : '' ) . + "'"; + my $sth = $tbl->do_query($query) or next; + my $tmp = { $sth->fetchall_list }; + + $words->{$word}->{word_info} = $tmp; + } + + return $words; +} + +## +# Internal Use +# $self->_cgi_to_hash ($in); +# -------------------------- +# Creates a hash ref from a cgi object. +## +sub _cgi_to_hash { + my ($self, $cgi) = @_; + $cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL'); + my @keys = $cgi->param; + my $result = {}; + foreach my $key (@keys) { + my @values = $cgi->param($key); + if (@values == 1) { $result->{$key} = $values[0] } + else { $result->{$key} = \@values } + } + return $result; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm b/site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm new file mode 100644 index 0000000..e751bd9 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm @@ -0,0 +1,98 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Indexer +# Author: Alex Krohn +# CVS Info : +# $Id: Indexer.pm,v 1.6 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Supports MS SQL full text indexer on MS SQL 2000 only. +# + +package GT::SQL::Search::MSSQL::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/; + + $ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MSSQLNONSUPPORT => 'You must be using MS SQL 2000 in order to use full text indexing. Current Database: %s', + CREATEINDEX => 'Problem Creating Full Text Index: %s' + }; + $ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +#-------------------------------------------------------------------------------- + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'ODBC') { + return $class->error ('MSSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + return 1; +} + +sub drop_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + + my $res = eval { + $table->do_query(" sp_fulltext_table '$name', 'drop' "); + $table->do_query(" sp_fulltext_catalog '$cat', 'drop' "); + 1; + }; + $res ? return 1 : return; +} + +sub add_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + my %weights = $table->weight; + my ($pk) = $table->pk; + +# Enable a database for full text indexing + $table->do_query(" sp_fulltext_database 'enable' ") or $self->error('CREATEINDEX', 'FATAL', $GT::SQL::error); +# Create a full text catalog to store the data. + $table->do_query(" sp_fulltext_catalog '$cat', 'create' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Make a unique index on primary key (not sure why it isn't by default. + $table->do_query(" create unique index PK_$name on $name ($pk) "); +# Mark this table as using the full text catalog created + $table->do_query(" sp_fulltext_table '$name', 'create', '$cat', 'PK_$name' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Specify which columns are to be indexed + foreach my $col (keys %weights) { + if ($weights{$col}) { + $table->do_query(" sp_fulltext_column '$name', '$col', 'add' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + } + } +# Must have a timestamp field. + $table->do_query(" alter table $name add timestamp "); +# Build the index. + $table->do_query(" sp_fulltext_table '$name', 'start_change_tracking' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + $table->do_query(" sp_fulltext_table '$name', 'start_background_updateindex' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + + return 1; +} + +sub post_create_table { +#-------------------------------------------------------------------------------- + shift->add_search_driver(@_); +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MSSQL/Search.pm b/site/glist/lib/GT/SQL/Search/MSSQL/Search.pm new file mode 100644 index 0000000..fa6694f --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MSSQL/Search.pm @@ -0,0 +1,179 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Search +# Author : Aki Mimoto +# CVS Info : +# $Id: Search.pm,v 1.9 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MSSQL::Search; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 2, + }; + +sub load { + shift; + return GT::SQL::Search::MSSQL::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# overruns the usual query system with the mssql version +# + my $self = shift; + +# Find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# Add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# Parse query..., + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + $self->{'rejected_keywords'} = $rejected; + +# Setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + +# Now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $string = $self->_string ($buckets); + + return $self->sth({}) unless ($string =~ /\w/); + + my $table_name = $tbl->name(); + my ($pk) = $tbl->pk; + +# create the filter + my $filter_sql = $self->{filter} ? "WHERE ( " . $self->{filter}->sql . ' )' : ''; + +# If we have a callback, we need all results. + if ($self->{callback}) { + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my %results = $tbl->do_query($query)->fetchall_list; + my $results = $self->{callback}->($self, \%results); + $self->{rows} = $results ? scalar keys %$results : 0; + return $self->sth($results); + } + else { + my $mh = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + my $nh = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; +# First get the total. + $query = qq! + SELECT COUNT(*) + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my ($count) = $tbl->do_query($query)->fetchrow; + +# Now get results. + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + ORDER BY K.RANK DESC + !; + my %results = $tbl->do_query($query)->fetchall_list; + $self->{rows} = $count; + return $self->sth(\%results); + } +} + +sub _string { +# ------------------------------------------------------------------- +# Returns the string to use for containstable. +# + my ($self, $buckets) = @_; + +# union + my $tmp_bucket = $buckets->{keywords}; + my $union_request_str = join( + " or ", + map( + qq!"$_"!, + keys %{$buckets->{phrases}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# intersect + $tmp_bucket = $buckets->{keywords_must}; + my $intersect_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_must}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# disjoin + $tmp_bucket = $buckets->{keywords_cannot}; + my $disjoin_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_cannot}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# now build the query + my $tmp_request_str = join( + " and ", + ($union_request_str ? "( $union_request_str )" : ()), + ($intersect_request_str ? "( $intersect_request_str )" : ()), + ($disjoin_request_str ? "NOT ( $disjoin_request_str )" : ()) + ); + return $tmp_request_str; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm b/site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm new file mode 100644 index 0000000..5e60c23 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm @@ -0,0 +1,187 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Indexer +# Author : Aki Mimoto +# CVS Info : +# $Id: Indexer.pm,v 1.17 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Indexer; +# ------------------------------------------------------------------------------ +use strict; +use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; +use GT::SQL::Search::Base::Indexer; +@ISA = qw/GT::SQL::Search::Base::Indexer/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/; + +$ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MYSQLNONSUPPORT => 'Driver MYSQL requires MySQL version 3.23.23 or greater. Currently MySQL version: %s' +}; + +@$GT::SQL::ERRORS{ keys %$ERRORS } = values %$ERRORS; + +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +# ------------------------------------------------------------------------------ + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'MYSQL') { + return $class->error ('MYSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + my $sth = $tbl->do_query(qq!SELECT VERSION()!); + my $version = $sth->fetchrow; + my ($maj, $min) = split (/\./, $version); + unless ($maj > 3 or ($maj == 3 and $min >= 23)) { + return $class->error(MYSQLNONSUPPORT => WARN => $version); + } + return 1; +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return; + $tbl->connect(); + + my %weights = $tbl->weight() or return; + my $tblname = $tbl->name(); + +# Group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Drop unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# For each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + DROP INDEX $ft_name + !); + }; + +# Break on errors that can't be handled + if ( $@ ) { + next if $@ !~ /exist/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return $self->error(BADARGS => FATAL => "table must be passed into add_search_driver."); + my %weights = $tbl->weight() or return $self->error(NOWEIGHTS => 'WARN'); + my $tblname = $tbl->name() or return $self->error(BADARGS => FATAL => "table does not have a name?"); + +# group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Create unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# for each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $cols = join(",", sort @{$cols_grouped{$v}}); + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + ADD FULLTEXT $ft_name ( $cols ) + !); + }; + +# break on errors that can't be handled + if ( $@ ) { + next if $@ =~ /duplicate/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; + +} + +sub too_much { +# ------------------------------------------------------------------------------ +# returns true if there are too many records to be used on the Web +# + if ( $ENV{REQUEST_METHOD} ) { + my $self = shift; + my $tbl = $self->{table}; + if ( $tbl->count() > 5000 ) { + $self->error( 'NOTFROMWEB', 'WARN', $tbl->name() ); + return 1 + } + } + return; +} + +sub post_create_table { +# ------------------------------------------------------------------------------ + shift->add_search_driver(@_); +} + +sub reindex_all { +# ------------------------------------------------------------------------------ +# this will drop all the fulltext columns and reindex all of them. This should +# not be required unless the user changes the weights on one of their columns. +# Unfortunately, this method is not particularly smart and risks not dropping +# certain index columns and reindexes even when it's not required. It must be +# recoded at a future date, but as this action won't happen frequently and will +# rarely affect the user, it is not a priority. +# + my $self = shift; + + $self->drop_search_driver; + $self->add_search_driver; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MYSQL/Search.pm b/site/glist/lib/GT/SQL/Search/MYSQL/Search.pm new file mode 100644 index 0000000..633f7df --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MYSQL/Search.pm @@ -0,0 +1,51 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Search +# Author : Aki Mimoto +# CVS Info : +# $Id: Search.pm,v 1.14 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Search; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub load { +# -------------------------------------------------- + my $self = shift; + my $opts = $self->common_param( @_ ); + +# determine which mysql search variant to use. + my $tbl = $opts->{table}; + my $ver_sth = $tbl->do_query( 'SELECT VERSION()' ); + my $version = $ver_sth->fetchrow_array(); + + my ( $maj, $min ) = split /\./, $version; + + my $pkg = 'GT::SQL::Search::MYSQL::'; + $pkg .= $maj > 3 ? 'VER4' : 'VER3'; + + eval "require $pkg"; + return $pkg->new(@_) +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm b/site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm new file mode 100644 index 0000000..cb0f3ee --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm @@ -0,0 +1,178 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER3 +# Author : Aki Mimoto +# CVS Info : +# $Id: VER3.pm,v 1.3 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER3; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub _phrase_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + + my $tmp = {}; + foreach my $keyword ( @{ $phrase->{phrase}|| [] } ) { + $tmp = $self->_get_words ( [ $keyword ], $tmp, 'intersect' ); + keys %$tmp or return {}; + } + foreach my $key ( keys %$tmp ) { $results->{$key} += $tmp->{$key} } + + } + + return $results; +} + +sub _get_phrase { +# ------------------------------------------------------------------------------ +# one day change this so it does words properly + return _get_words(@_); +} + +sub _union_query { +# ------------------------------------------------------------------------------ + return _get_words(@_); +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ + my ( $self, $keywords, $results ) = @_; + $keywords or return $results; + + foreach my $keyword ( keys %{ $keywords || {} } ) { + $results = $self->_get_words ( [ $keyword ], $results, 'intersect' ); + keys %$results or return {}; + } + + return $results; +} + +sub _phrase_intersect_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + if ( $tmp->{$key} ) { + $results->{$key} += $tmp->{$key}; + } + else { + delete $results->{$key} + } + } + + return $results; +} + +sub _disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return shift; + my $results = shift || {}; + + $results = $self->_get_words([ keys %{$words || {}} ], $results, 'disjoin' ); + + return $results; +} + +sub _phrase_disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return shift; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + $tmp->{$key} and delete $results->{$key}; + } +} + +sub _get_words { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return $_[0] || {}; + my $results = shift || {}; + my $mode = lc shift; + + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $tname = $tbl->name(); + my $wordlist = join " ", ( ref $words ? ( ref $words eq 'HASH' ? keys %$words : @$words ) : $words ) ; + my ($pk) = $tbl->pk; + + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + my $qwrds = quotemeta( $wordlist ); + my $where = ( $results and keys %$results ) + ? ("AND $pk IN(" . join(',', keys %$results) . ")") + : ''; + my $query = qq! + SELECT $pk, MATCH($cols) AGAINST ('$qwrds') AS SCORE + FROM $tname + WHERE MATCH($cols) AGAINST ('$qwrds') + $where + !; + my $sth = $tbl->do_query( $query ) or return; + + if ( $mode eq 'disjoin' ) { + while ( my $result = $sth->fetchrow ) { + delete $results->{$result}; + } + } + elsif ( $mode eq 'intersect' ) { + my $tmp = {}; + while ( my $aref = $sth->fetchrow_arrayref ) { + $tmp->{$aref->[0]} = $aref->[1]; + } + if ( $results and keys %$results ) { + while (my ($id, $score) = each %$results) { + if (not defined $tmp->{$id}) { + delete $results->{$id}; + next; + } + $results->{$id} += $score; + } + } + else { + $results = $tmp; + } + } + else { + while ( my $aref = $sth->fetchrow_arrayref ) { + $results->{$aref->[0]} += $aref->[1]; + } + } + return $results; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm b/site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm new file mode 100644 index 0000000..bf40ec7 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm @@ -0,0 +1,355 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER4 +# Author : Aki Mimoto +# CVS Info : +# $Id: VER4.pm,v 1.9 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER4; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $STOPWORDS = { map { $_ => 1 } qw/ + + a's able about above according accordingly across actually after + afterwards again against ain't all allow allows almost alone + along already also although always am among amongst an and another + any anybody anyhow anyone anything anyway anyways anywhere apart + appear appreciate appropriate are aren't around as aside ask asking + associated at available away awfully be became because become becomes + becoming been before beforehand behind being believe below beside + besides best better between beyond both brief but by c'mon c's came + can can't cannot cant cause causes certain certainly changes clearly + co com come comes concerning consequently consider considering + contain containing contains corresponding could couldn't course currently + definitely described despite did didn't different do does doesn't + doing don't done down downwards during each edu eg eight either else + elsewhere enough entirely especially et etc even ever every everybody + everyone everything everywhere ex exactly example except far few + fifth first five followed following follows for former formerly + forth four from further furthermore get gets getting given gives + go goes going gone got gotten greetings had hadn't happens hardly + has hasn't have haven't having he he's hello help hence her here + here's hereafter hereby herein hereupon hers herself hi him himself + his hither hopefully how howbeit however i'd i'll i'm i've ie if ignored + immediate in inasmuch inc indeed indicate indicated indicates inner + insofar instead into inward is isn't it it'd it'll it's its itself + just keep keeps kept know knows known last lately later latter latterly + least less lest let let's like liked likely little look looking looks + ltd mainly many may maybe me mean meanwhile merely might more + moreover most mostly much must my myself name namely nd near nearly + necessary need needs neither never nevertheless new next nine no + nobody non none noone nor normally not nothing novel now nowhere + obviously of off often oh ok okay old on once one ones only onto + or other others otherwise ought our ours ourselves out outside over + overall own particular particularly per perhaps placed please plus + possible presumably probably provides que quite qv rather rd re + really reasonably regarding regardless regards relatively respectively + right said same saw say saying says second secondly see seeing seem + seemed seeming seems seen self selves sensible sent serious seriously + seven several shall she should shouldn't since six so some somebody + somehow someone something sometime sometimes somewhat somewhere + soon sorry specified specify specifying still sub such sup sure + t's take taken tell tends th than thank thanks thanx that that's + thats the their theirs them themselves then thence there there's + thereafter thereby therefore therein theres thereupon these they + they'd they'll they're they've think third this thorough thoroughly + those though three through throughout thru thus to together too + took toward towards tried tries truly try trying twice two un + under unfortunately unless unlikely until unto up upon us use used + useful uses using usually value various very via viz vs want wants + was wasn't way we we'd we'll we're we've welcome well went were + weren't what what's whatever when whence whenever where where's + whereafter whereas whereby wherein whereupon wherever whether + which while whither who who's whoever whole whom whose why will + willing wish with within without won't wonder would would wouldn't + yes yet you you'd you'll you're you've your yours yourself + yourselves zero + + / }; + + $ATTRIBS = { + min_word_size => 4, + stopwords => $STOPWORDS, + }; + +sub query { +# -------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# create an easily accessible argument hash + my $args = $self->common_param(@_); + +# see if we can setup the filtering constraints + my $filter = { %$args }; + my $query = delete $args->{query} || $self->{query} || ''; + my $ftr_cond; + +# parse query + $self->debug( "Search Query: $query" ) if ($self->{_debug}); + my ( $query_struct, $rejected ) = $self->_parse_query_string( $query ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query_struct = $self->_preset_options( $query_struct, $args ); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + +# with the buckets, it's now possible to create a query string +# that can be passed directly into the FULLTEXT search. + my $query_string = ''; + + foreach my $search_type ( keys %$buckets ) { + my $bucket = $buckets->{$search_type}; + foreach my $token ( keys %$bucket ) { + next unless $token; + my $properties = $bucket->{$token} or next; + + my $e = ' '; + +# handle boolean operations + $properties->{mode} ||= ''; + if ( $properties->{mode} eq 'must' ) { + $e .= '+'; + } + elsif ( $properties->{mode} eq 'cannot' ) { + $e .= '-'; + } + +# deal with phrase vs keyword + if ( $properties->{phrase} ) { + $e .= '"' . quotemeta( $token ) . '"'; + } + else { + $e .= quotemeta $token; + +# substring match + $e .= '*' if $properties->{substring}; + } + + $query_string .= $e; + } + } + +# start building the GT::SQL::COndition object that will allow us to +# to retreive the data + + require GT::SQL::Condition; + my $tbl = $self->{table}; + my $constraints = GT::SQL::Condition->new; + +# create the GT::SQL::Condition object that will become the filtering +# constraints + my $filt = $self->{filter}; + + if ( $filt and ref $filt eq 'HASH' ) { + foreach my $fkey ( keys %$filt ) { + next if exists $args->{$fkey}; + $args->{$fkey} = $filt->{$fkey}; + } + } + + if ( my $filter_cond = $tbl->build_query_cond( $args ) ) { + $constraints->add( $filter_cond ); + } + +# if the cached filter object is a Condition object, append +# it to the filter set + if ( $filt and UNIVERSAL::isa( $filt, 'GT::SQL::Condition' ) ) { + $constraints->add( $filt ); + } + +# create our fulltext query condition + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + if ( $query_string ) { + $constraints->add( GT::SQL::Condition->new( + "MATCH( $cols )", + "AGAINST", + \"('$query_string' IN BOOLEAN MODE)" ) ); + } + +# calculate the cursor constraints + foreach my $k (qw( nh mh so sb )) { + next if defined $args->{$k}; + $args->{$k} = $self->{$k} || ''; + } + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25; + $args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score'; + +# if the sorting method is "score" the order is forced to "descend" (as there +# is almost no reason to order by worst matches) +# if the storing key is not "score", the default order will be "ascend" + $args->{so} = + $args->{sb} eq 'score' ? 'desc' : # comment out this entire line to prevent "descend" order forcing + ( (defined $args->{so} and $args->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : 'asc' ); + +# check that sb is not dangerous + my $sb = $self->clean_sb($args->{sb}, $args->{so}); + + $self->debug_dumper( "About to query. Constraint object: ", $constraints) if ($self->{_debug}); + +# Setup a limit only if there is no callback. The callback argument requires a full results list + unless ( $self->{callback} ) { + my $offset = ( $args->{nh} - 1 ) * $args->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $args->{mh}"); + } + + my $sth; + +# if the weights are all the same value, the query can be optimized +# to use just one MATCH AGAINST argument. However, if the weights +# are different, each element must be sectioned and queried separately +# with the weight value multipler + +# check to see if all the weight values are the same. + my $base_weight; + my $weights_same = 1; + foreach ( values %weights ) { + $base_weight ||= $_ or next; # init and skip 0s + next if $base_weight == $_; + $weights_same = 0; + last; + } + +# multiplex the action + my $result_cols = $self->{callback} ? ($tbl->pk)[0] : '*'; + + unless ( $query_string ) { + $sth = $tbl->select( [ $result_cols ], $constraints ) or return; + } + elsif ( $weights_same ) { + $sth = $tbl->select( [ $result_cols, "MATCH($cols) AGAINST ('$query_string' IN BOOLEAN MODE) AS score" ], $constraints ) + or return; + } + else { + +# group the multiplier counts + my %column_multiplier; + foreach ( keys %weights ) { + push @{$column_multiplier{$weights{$_}}}, $_; + } + + my @search_parameters; + foreach my $val ( keys %column_multiplier ) { + next unless $val; + + my $cols_ar = $column_multiplier{ $val } or next; + my $search_cols = join ",", @$cols_ar; + + if ( $val > 1 ) { + push @search_parameters, "( ( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) ) * $val )"; + } + else { + push @search_parameters, "( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) )"; + } + } + + my $search_sql = "( " . join( " + ", @search_parameters ) . " ) AS score"; + + $sth = $tbl->select( [ $result_cols, $search_sql ], $constraints ) + or return; + } + +# If we have a callback, we fetch the primary key => score and pass that hash into +# the filter. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + my %results = map { $_->[0] => $_->[1] } @{$sth->fetchall_arrayref}; + + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %results) . " results.", \%results) if ($self->{_debug}); + my $filtered = $self->{callback}->($self, \%results) || {}; + $self->debug_dumper("New result set: " . scalar (keys %$filtered) . " results.", $filtered) if ($self->{_debug}); + + $self->{rows} = scalar keys %$filtered; + return $self->sth($filtered); + } + +# count the number of hits. create a query for this purpose only if we are required to. + $self->{rows} = $sth->rows(); + if (($args->{nh} > 1) or ($self->{rows} == $args->{mh})) { + $self->{rows} = $tbl->count($constraints); + } + return $sth; +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm b/site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm new file mode 100644 index 0000000..ecf3c08 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm @@ -0,0 +1,25 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Indexer +# Author: Aki Mimoto +# CVS Info : +# $Id: Indexer.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::NONINDEXED::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $DEBUG/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Indexer->new(@_) +} + +1; diff --git a/site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm b/site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm new file mode 100644 index 0000000..ebe9290 --- /dev/null +++ b/site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm @@ -0,0 +1,255 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Search +# Author : Alex Krohn +# CVS Info : +# $Id: Search.pm,v 1.28 2004/08/28 03:53:50 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Nonindex search system +# + +package GT::SQL::Search::NONINDEXED::Search; +# ================================================================== + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG/; + use GT::SQL::Search::Base::Search; + use GT::SQL::Condition; + @ISA = qw( GT::SQL::Search::Base::Search ); + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# parse based on latin characters + latin_query_parse => 0 + }; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + + require GT::SQL::Condition; + my $query_condition = new GT::SQL::Condition; + +# now handle the separate possibilities +# the union + my $union_cond = $self->_get_condition( $buckets->{keywords}, $buckets->{phrases} ); + $query_condition->add(GT::SQL::Condition->new(@$union_cond, 'OR')) if $union_cond; +# the intersect + my $intersect_cond = $self->_get_condition( $buckets->{keywords_must}, $buckets->{phrases_must} ); + $query_condition->add(GT::SQL::Condition->new(@$intersect_cond)) if $intersect_cond; + +# the disjoin + my $disjoin_cond = $self->_get_condition( $buckets->{keywords_cannot}, $buckets->{phrases_cannot} ); + $query_condition->add(GT::SQL::Condition->new(@$disjoin_cond, 'OR')->not) if $disjoin_cond; + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $column = $_) =~ s/-[lg]t$//; + exists $cols->{$column} + ? ($_ => $input->{$_}) + : () + } keys %{$input}; + +# if there was no query nor filter return nothing. + keys %$query or keys %filters or return $self->sth({}); + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $self->_add_filters( \%filters ); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + elsif ($self->{filter} and keys %{$self->{filter}} ) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll do that here + $self->{filter} = undef; + + my $tbl = $self->{table}; + my ($pk) = $tbl->pk; + +# now run through a callback function if needed. + if ($self->{callback}) { + +# Warning: this slows things a heck of a lot. + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + + my $sth = $tbl->select( [ $pk ], $query_condition ); + my $results = {}; + while (my $result = $sth->fetchrow) { + $results->{$result} = undef; + } + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $self->{rows} = scalar($results ? keys %{$results} : ()); + + return $self->sth( $results ); + } + +# and now create a search sth object to handle all this + $input->{nh} = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + $input->{mh} = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; + $input->{so} = (defined $input->{so} and $input->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : ''; + +# check that sb is not dangerous + my $sb = $self->clean_sb($input->{sb}, $input->{so}); + + my $offset = ( $input->{nh} - 1 ) * $input->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $input->{mh}"); + my $sth = $tbl->select( $query_condition ) or return; + +# so how many hits did we get? + $self->{rows} = $sth->rows(); + if (($input->{nh} > 1) or ($self->{rows} == $input->{mh})) { + $self->{rows} = $tbl->count($query_condition); + } + return $sth; +} + +sub _get_condition { +#------------------------------------------------------------------------------- + my ( $self, $keywords, $phrases ) = @_; + + my @list = ( keys %$keywords, keys %$phrases ); + + my $tbl = $self->{table} or return $self->error( 'NODRIVER', 'FATAL' ); + my @cond = (); + my %tmp = $tbl->weight(); + my @weights = keys %tmp or return; + foreach my $element ( @list ) { + my @where = (); + foreach my $cols ( @weights ) { + push @where, [$cols, 'LIKE', "%$element%"]; # Condition does quoting by default. + } + push @cond, GT::SQL::Condition->new(@where, 'OR'); + } + @cond or return; + + return \@cond; +} + +sub _parse_query_string { +#------------------------------------------------------------ +# Parses a query string '+foo -"bar this" alpha' into a hash of +# words and modes. +# + my ($self, $text) = @_; + my %modes = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# Latin will break up on actual words and punctuation. + if ($self->{latin_query_parse}) { + return $self->SUPER::_parse_query_string( $text ); + } + else { + my $words = {}; + my @terms; + my $i = 0; + foreach my $term (split /"/, $text) { + push @terms, ($i++ % 2 ? $term : split ' ', $term); + } + for (my $i = 0; $i < @terms; $i++) { + my $word = $terms[$i]; + $word =~ s/^\s*|\s*$//g; + next if ($word eq ''); + ($word eq '-') and ($word = '-' . $terms[++$i]); + ($word eq '+') and ($word = '+' . $terms[++$i]); + $word =~ s/^([<>+-])//; + my $mode = ($1 and $modes{$1} or 'can'); + my $substring = ($word =~ s/\*$//) || 0; + if ($word =~ /\s/) { + $words->{$word} = { + mode => $mode, + phrase => 1, + substring => $substring, + keyword => 0, + }; + } + else { + $words->{$word} = { + mode => $mode, + phrase => 0, + substring => $substring, + keyword => 1, + }; + } + } + return $words; + } +} + +1; diff --git a/site/glist/lib/GT/SQL/Table.pm b/site/glist/lib/GT/SQL/Table.pm new file mode 100644 index 0000000..3a689c8 --- /dev/null +++ b/site/glist/lib/GT/SQL/Table.pm @@ -0,0 +1,2955 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# CVS Info : +# $Id: Table.pm,v 1.251 2005/02/28 20:37:41 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to store and retrieve data from a table. +# + +package GT::SQL::Table; +# =============================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::Config; +use GT::AutoLoader(NAME => '_AUTOLOAD'); +use strict; +use vars qw/$DEBUG $VERSION @ISA $AUTOLOAD $ERROR_MESSAGE @COL_ATTRIBS/; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.251 $ =~ /(\d+)\.(\d+)/; +@COL_ATTRIBS = qw/size type values default not_null pos regex weight form_display form_size form_type form_names form_values time_check/; +$ERROR_MESSAGE = 'GT::SQL'; + +use constants DEF_HEADER => <<'HEADER'; +# Database definition file for '%TABLE_NAME%' table +# Last updated: [localtime] +# Created by GT::SQL::Table $Revision: 1.251 $ +HEADER + +sub new { +# ----------------------------------------------------------------------------- +# GT::SQL::Table->new( +# name => table_name, +# debug => debug level, +# _err_pkg => package name, +# driver => driver name, +# ); +# ----------------------------------------------------------------------------- +# Constructs (or returns if it already exists) a new GT::SQL::Object with the +# parameters specified above. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->new(HASH or HASH_REF or CGI) only'); + + $self->{connect} = $opts->{connect} || {}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{_index} = 0; + $self->{_file} = 0; + +# Must have {connect} info first. + $self->name($opts->{name}); + $self->{name} ||= ''; + if (-f "$self->{connect}->{def_path}/$self->{name}.def" and not $opts->{_schema}) { + $self->load_state; + } + elsif ($opts->{_schema} and UNIVERSAL::isa($opts->{_schema}, 'GT::Config')) { + # If _schema is passed as a GT::Config object, use it directory. This + # is primarily used for subclassed tables - see GT::SQL::Base::new_table() + $self->{schema} = $opts->{_schema}; + } + else { + $self->{schema} = { %{$opts->{_schema}} } if $opts->{_schema}; + $self->_new_schema if length $self->{name}; + } + +# Some defaults for writing to + $self->{schema}->{index} ||= {}; + $self->{schema}->{unique} ||= {}; + $self->{schema}->{cols} ||= {}; + $self->{schema}->{pk} ||= []; + $self->{schema}->{fk} ||= {}; + $self->{schema}->{subclass} ||= {}; + $self->{schema}->{ai} ||= ''; + $self->{schema}->{fk_tables} ||= []; + + { # Check for weights or file columns and set _file and _index accordingly + my ($found_file, $found_weight); + my $c = $self->{schema}->{cols}; + for (keys %$c) { + if (!$found_file and $c->{$_}->{form_type} and uc $c->{$_}->{form_type} eq 'FILE') { + $self->_file_cols(); + $self->{_file} = ++$found_file; + } + if (!$found_weight and $c->{$_}->{weight}) { + $self->{_index} = ++$found_weight; + } + last if $found_file and $found_weight; + } + } + + $self->debug("Table '$self->{name}' object created.") if ($self->{_debug} > 2); + return $self; +} + +sub DESTROY {} + +sub AUTOLOAD { +# ------------------------------------------------------------- +# This method provides get methods for all the cols attributes. +# It returns a hash reference of the column names to the value +# of the attribute for that attribute. +# + my $self = $_[0]; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + +# Otherwise we have auto generated functions for each of the +# column names. + if (grep { $what eq $_ } @COL_ATTRIBS) { + no strict 'refs'; + *$AUTOLOAD = sub { + my $self = shift; + my $h = {}; + for my $col (keys %{$self->{schema}->{cols}}) { + if (exists $self->{schema}->{cols}->{$col}->{$what}) { + $h->{$col} = $self->{schema}->{cols}->{$col}->{$what}; + } + } + wantarray ? %$h : $h; + }; + goto &$AUTOLOAD; + } + +# Pass to the imported &_AUTOLOAD, which handles loading from %COMPILE + goto &_AUTOLOAD; +} + +# Loads a new ->{schema} GT::Config object that, when saved, will create the +# def file. The config object created is always empty, but any existing values +# in ->{schema} will be copied into the object. Thus, saving will always +# overwrite anything stored in this table's def file. +$COMPILE{_new_schema} = __LINE__ . <<'END_OF_SUB'; +sub _new_schema { + my $self = shift; + my $name = $self->name; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + my %old = $self->{schema} ? %{$self->{schema}} : (); + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + local => 0, + empty => 1, + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + %{$self->{schema}} = %old; + $self->{schema}; +} +END_OF_SUB + +sub load_state { +# ----------------------------------------------------------------------------- +# $obj->load_state; +# ----------------- +# Loads relation structure from def file. If you want to reload the +# structure currently stored on disk, you should call ->reload or ->reset - +# this method caches files (via GT::Config). +# + my ($self, $reload) = @_; + my $name = $self->name; + -e "$self->{connect}->{def_path}/$name.def" or return $self->fatal(FILENOEXISTS => "$self->{connect}->{def_path}/$name.def"); + $self->debug("Loading state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + cache => !($reload and $reload eq 'reload'), + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + $self->{driver}->{schema} = $self->{schema} if $self->{driver} and exists $self->{driver}->{schema}; + $self->debug("State loaded for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + return 1; +} + +$COMPILE{reload} = __LINE__ . <<'END_OF_SUB'; +sub reload { +# ----------------------------------------------------------------------------- +# $obj->reload; +# ------------- + shift->load_state('reload'); +} +END_OF_SUB + +sub reset { +# ----------------------------------------------------------------------------- +# Works just like reload, except it always returns false, allowing for a +# shortcut such as: +# +# $code->that_changes($table) or return $table->reset; +# + shift->load_state('reload'); + return; +} + +# -------------------------------------------------------------------------------------- # +# SQL OPERATIONS # +# -------------------------------------------------------------------------------------- # + +sub add { +# ----------------------------------------------------------- +# add() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to add. +# OUT: ID number if auto_incremented table, or undef if failure +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->add(HASH or HASH_REF or CGI) only.'); + $input = {%$input}; + my $table = $self->name or return $self->fatal('NOTABLE'); + + my $c = $self->{schema}->{cols}; + my $ai = $self->{schema}->{ai}; + my $err = 0; + + my %skip_check = ( + $ai => 1 + ); + + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + $skip_check{$tree->father_id_col}++; + $skip_check{$tree->root_id_col}++; + $skip_check{$tree->depth_col}++; + } + +# Clear errors. + $self->{_error} = []; + + for my $col (keys %$c) { + my $default = $c->{$col}->{default}; + next if $skip_check{$col}; + my $set = defined $input->{$col} && $input->{$col} =~ /\S/; + unless ($set) { + if ($c->{$col}->{not_null} and (!defined $default or !length $default)) { + $self->warn(NOTNULL => $c->{$col}->{form_display} || $col); + $err = 1; + } + elsif ($c->{$col}->{type} eq 'INTEGER' or $c->{$col}->{type} =~ /INT$/ or $c->{$col}->{type} =~ /FLOAT|REAL|DOUBLE|DECIMAL/) { + # A numeric column with a blank value doesn't get passed to + # insert(); it'll either be inserted as the default, or NULL. + delete $input->{$col}; + } + } + } + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + my $sth = $self->insert($input); + return $sth ? $ai ? $sth->insert_id : 1 : undef; +} + +sub insert { +# ----------------------------------------------------------- +# $obj->insert(key1 => $value1, key2 => $value2); +# ------------------------------------------------ +# Key values pairs that correspond to the row you are +# inserting. +# +# $obj->insert(\%row); +# --------------------- +# A hash that contains key value pairs that corespond to +# the row you are inserting. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF) only.'); + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data. + keys %$opts or return $self->warn(NOVALUES => "insert()"); + +# Copy the data and remove anything that doesn't make sense here. + my $c = $self->{schema}->{cols}; + my %set = map { exists $opts->{$_} ? ($_ => $opts->{$_}) : () } keys %$c; + +# Check for file uploads. + my (%fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) { + require GT::SQL::File; + %fset = GT::SQL::File->pre_file_actions( \%fcols, \%set, $opts ) or ( $GT::SQL::error and return ); + + } + + my $tree; + if ($self->{schema}->{tree}) { + $tree = $self->tree; + my $f = $tree->father_id_col; + my $r = $tree->root_id_col; + my $d = $tree->depth_col; + if ($set{$f}) { + my $pk = $self->{schema}->{pk}->[0]; + my ($root, $depth) = $self->select($r, $d, { $pk => $set{$f} })->fetchrow; + $set{$r} = $root || $set{$f}; + $set{$d} = $depth + 1; + } + else { + $set{$f} = $set{$r} = $set{$d} = 0; # A root record + } + } + + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_insert(\%set) or return; + } + $self->{last_insert} = \%set; + +# Weighted indexing needs special handling + my $tmp_weight; + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $tmp_weight = $self->_get_indexer->pre_add_record( $self->{last_insert} ) or return; + } + + my $sth = $self->{driver}->insert(\%set) or return; + +# If we have files, let's save them. + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + for ( keys %fcols ) { $set{$_} = $fset{$_}; $set{$_."_filename"} = $opts->{$_."_filename"} }; + if ( ( my @pk = $self->pk() ) == 1 and keys %fcols ) { + my $key = ( $self->ai() ? $sth->insert_id : $set{$pk[0]} ); + require GT::SQL::File; + my $tbl = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }) or return; + $tbl->add_file( \%set, $key ) or return; + } + } + +# Finish off special handling for weighted indexing + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $self->_get_indexer->post_add_record( $self->{last_insert}, $sth, $tmp_weight ) or return; + } + +# If a tree exists, insert any new entries required + if ($self->{schema}->{tree}) { + $tree->insert(insert_id => $sth->insert_id, data => \%set); + } + + return $sth; +} + +$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB'; +sub insert_multiple { +# ----------------------------------------------------------- +# $obj->insert_multiple(['key1', 'key2', 'key3'], [$value1_1, $value1_2, $value1_3], [$value2_1, $value2_2, $value2_3], ...); +# ------------------------------------------------ +# The first array ref is the columns, and all following array refs are the +# values to be inserted. +# +# This method doesn't mess around - it doesn't check to make sure all the +# columns you entered exist, nor does it do foreign key checks, nor does it +# handle raw SQL values via scalar references (it does, however, support +# undef as NULL). Currently, it does not support file columns or columns +# indexed by GT::SQL's 'INTERNAL' indexer. +# +# Returned is the number of _queries_ successfully executed, or undef if no +# queries were executed successfully. Note that the number of queries is not +# necessarily the same as the number of rows insert - in particular, several +# rows may be inserted in a single query in some databases (currently, +# MySQL). +# + my ($self, $cols, @values) = @_; + $cols or return $self->fatal(BADARGS => 'Usage: $obj->insert_multiple(ARRAY_REF, ARRAY_REF, ...) only'); + + my $table = $self->name or return $self->fatal('NOTABLE'); + + $self->{schema}->{tree} and return $self->fatal(TREENOCANDO => 'insert_multiple', $table); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data, and the right number for each insert. + @values or return $self->warn(NOVALUES => "insert()"); + for my $val (@values) { + if (@$val != @$cols) { + return $self->fatal(BADMULTVALUES => 'insert_multiple()'); + } + } + + my $c = $self->{schema}->{cols}; + for (my $i = 0; $i < @$cols; $i++) { + unless (exists $c->{$cols->[$i]}) { + splice @$cols, $i, 1; + for my $val (@values) { + splice @$val, $i, 1; + } + --$i; + } + } + +# Query is executed inside to handle ai fields. + $self->{driver}->insert_multiple($cols, \@values) or return; +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF or CGI) only.'); + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + + my $c = $self->{schema}->{cols}; + my $set = {}; + my $err = 0; +# Copy the data and remove anything that doesn't make sense here. Also, set +# errors for not null checks. + + for my $col (keys %$c) { + $input->{$col."_del"} and ( $set->{$col."_del"} = $input->{$col."_del"} ); + $input->{$col."_filename"} and ( $set->{$col."_filename"} = $input->{$col."_filename"} ); + exists $input->{$col} ? ($set->{$col} = $input->{$col}) : next; + next if ($col eq $self->{schema}->{ai}); + if (exists $c->{$col}->{not_null} and $c->{$col}->{not_null} and (!exists $input->{$col} or ($input->{$col} =~ /^\s*$/))) { + if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE') { + my ( $pk ) = $self->pk(); + $input->{$col} = $self->file_info( $col, $input->{$pk} ); + next; + } + $self->warn(NOTNULL => $c->{$col}->{form_display} || $col); + $err = 1; + } + } + +# Remove primary keys from update clause and make sure we have a primary key. + my $where; + for my $key (@{$self->{schema}->{pk}}) { + $where->{$key} = delete $set->{$key} if exists $set->{$key}; + } + unless (keys %{$where} == @{$self->{schema}->{pk}}) { + $self->warn('NOPKTOMOD'); + $err = 1; + } + +# Remove timestamps - no sense updating. + $err = 1 unless $self->_check_timestamp($where, $set); + for my $col (keys %$c) { +# Backwards compatibility, remove int's that are set to empty string. + my $is_set = defined $set->{$col} && $set->{$col} =~ /\S/; + if (!$is_set and ($c->{$col}->{type} eq 'INTEGER' or $c->{$col}->{type} =~ /INT$/ or $c->{$col}->{type} =~ /FLOAT|REAL|DOUBLE|DECIMAL/)) { + # A numeric column with a blank value doesn't get passed to + # modify(); it'll either be inserted as the default, or NULL. + delete $set->{$col}; + } + delete $set->{$col} if $c->{$col}->{type} eq 'TIMESTAMP'; + } + +# If we caught any errors, return. + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + +# Execute the update + $self->update($set, $where) or return; + return 1; +} +END_OF_SUB + +sub update { +# ----------------------------------------------------------- +# $obj->update($hash_ref, $condition, $opts); +# ------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->update($hash_ref_1, $hash_ref_2, $opts); +# ---------------------------------------- +# Hash1 is what needs to be changed. +# Hash2 is the condition. +# + my $self = shift; + my ($set, $where, $opts) = @_; + ref $set eq 'HASH' or return $self->fatal(BADARGS => 'Usage: $obj->update(HASH_REF, CONDITION_OBJ or HASH_REF, HASH_REF)'); + keys %$set or return $self->fatal(BADARGS => 'update called with nothing to set!'); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Check to make sure the update is possible + $opts ||= {}; + $where ||= {}; # Update all. + +# Check to see if we have files to update. + my (%fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols() ) { + require GT::SQL::File; + %fset = GT::SQL::File->pre_file_actions( \%fcols, $set, $opts ) or ( $GT::SQL::error and return ); + + if (not keys %$set and not keys %fset) { + return $self->warn(BADARGS => "update called with nothing to set!"); + } + } + + my $where_cond = $self->_build_cond($where); + +# If there is a tree, and the father_id is being updated, call the appropriate tree method. + my $tree_data; + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + if (exists $set->{$tree->father_id_col}) { + $tree_data = $tree->pre_update(where => $where_cond, data => $set) or return; + } + } + +# Validate data. + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_update($set, $where) or return; + } + my $set_cond = $self->_build_set($set); + +# If we are updating this tables primary key, then get the original +# value and save it for after the update. + my $pk = $self->{schema}->{pk}; + my $where_r = $where_cond->as_hash; + my @update_pk; + for (@$pk) { + if (defined $set->{$_} and defined $where_r->{$_} and $set->{$_} ne $where_r->{$_}) { + push @update_pk, $_; + } + } + +# Update the search index if changing a weighted column. + my $tmp_weights = {}; + my %wcols; + if ($self->{_index} and ! $opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $tmp_weights = $self->_get_indexer->pre_update_record( $set_cond, $where_cond ) or return; + last; + } + } + } + + $self->{sel_opts} ||= []; + +# Save the where clause. + $self->{last_where} = $where_cond; + +# Perform the update. + my $sth = $self->{driver}->update($set_cond, $where_cond) or return; + +# The query was successful, so now if there is a tree, call the tree's update method + if ($tree_data) { + $self->tree->update($tree_data); + } + +# Update the foreign keys of other tables if this tables primary key changed. + for my $key (@update_pk) { + for my $table (@{$self->{schema}->{fk_tables}}) { + my $new_me = $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + my $fk_hash = $new_me->{schema}->{fk}->{$self->name} or next; + for my $my_col (keys %$fk_hash) { + if ($fk_hash->{$my_col} eq $key) { + $new_me->update({ $my_col => $set->{$key} }, { $my_col => $where_r->{$key} }); + } + } + } + } + +# Update any file changes. + if (keys %fcols and $self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + for (keys %fcols) { + $set->{$_} = $fset{$_}; + $set->{$_."_del"} = $fset{$_."_del"}; + } + $File->update_records($set, $where_cond) or return; + } + +# Update the search index if required. + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $self->_get_indexer->post_update_record( $set_cond, $where_cond, $tmp_weights ) or return; + last; + } + } + } + return $sth; +} + +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition); +# -------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->delete($val); +# ---------------------- +# Deletes a single record based on the scalar value being the +# primary key. +# +# $obj->delete([$val1, $val2]); +# -------------------------------- +# If you have a composite primary key, deletes a single record +# based on the values being the primary keys. +# +# NOTE: use delete_all to delete everything +# + my $self = shift; + @_ > 0 or return $self->fatal(BADARGS => "You must call delete_all to delete all entries"); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; +# Clear errors. + $self->{_error} = []; + + my ($opt, $cond, $where, $do_select, %del, @rows); + +# Determine what sort of delete to do. + unless (@_ == 1) { + for my $i (0 .. $#_) { + $_ = $_[$i]; + /^abort$/ and do { $opt = splice(@_, $i, 1); last }; + /^cascade$/ and do { $opt = splice(@_, $i, 1); last }; + /^ignore$/ and do { $opt = splice(@_, $i, 1); last }; + /^cleanup$/ and do { $opt = splice(@_, $i, 1); last }; + } + } + +# Get the where clause we are going to use to do the delete. This can be +# either from a a scalar/array reference representing the primary key, or a +# condition/hash reference representing a where clause. + if ( ((ref $_[0] eq 'ARRAY') or (not ref $_[0])) and (@_ == 1) ) { + my @keys = @{$self->{schema}->{pk}}; + my @vals = ref $_[0] ? @{shift()} : shift(); + my $href = {}; + if (@keys != @vals) { + return $self->fatal(BADARGS => "Your primary key is made of " . @keys . " elements, but you passed in " . @vals . " elements."); + } + while (@vals) { + $href->{shift(@keys)} = shift(@vals); + } + (keys %{$href}) or return $self->fatal(BADARGS => 'Usage: $obj->delete(CONDITION_OBJ or PRIMARY_KEY or [PRIMARY_KEY1, PRIMARY_KEY2])'); + $where = $self->_build_cond($href); + } + else { + ($where, $do_select) = _extract_where(@_); + } + +# Make sure $where is not empty. + if (! $where->sql) { + return $self->fatal(BADARGS => "Could not create a condition object out of arguments."); + } + +# Save the where clause. + $self->{last_where} = $where; + $opt ||= 'cascade'; + +# Do a 'cascade' or 'abort' delete. + if ($opt ne 'ignore' and $opt ne 'cleanup') { + my $q; +# If they passed in a complex condition we select + if ($do_select) { + $q = $self->select($where); + } +# If the hash that was passed in does not contain the foreign keys we select + elsif (not $self->_check_keys($where)) { + $q = $self->select($where); + } + + if ($q) { $self->_delete_select($q, $opt) or return } + else { $self->_delete_cond($where, $opt) or return } + } + +# now handle the indexes if that's required + my $tmp_weights = {}; + if ($self->{_index} and $self->_weight_cols) { + $tmp_weights = $self->_get_indexer()->pre_delete_record( $where ) or return; + } + +# delete anything related to tables + if ($self->{_file} and $self->_file_cols() ) { + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $file->delete_records( $where ); + } + +# For many to one fk relations + my $rows; + if ($opt eq 'cleanup') { + defined($rows = $self->_delete_cleanup($where)) or return; + } + else { +# Get the SQL. + my $sth = $self->{driver}->delete($where) or return; + $rows = $sth->rows; + } + + if ($self->{_index} and $self->_weight_cols) { + $self->_get_indexer()->post_delete_record( $where, $tmp_weights ) or return; + } + + defined $rows or return; + return ($rows == 0) ? "0E0" : $rows; +} + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# $obj->delete_all; +# ----------------- +# Deletes all the records in the current table. +# + my ($self, $opt, $done) = @_; # $done is used internally + $opt ||= 'cascade'; + my $name = $self->name or return $self->fatal('NOTABLE'); + $done ||= { $name => 1 }; + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Do the cascading delete. + for my $fktable (@{$self->fk_tables}) { + next if $done->{$fktable}++; + my $new_me = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + if ($opt eq 'cascade') { + $done->{$fktable}++; + $new_me->delete_all($opt, $done) or return; + } + else { + $new_me->count and return $self->warn(DEPENDENCY => $fktable); + } + } + my $tmp_weights = {}; + if ($self->_weight_cols()) { $tmp_weights = $self->_get_indexer()->pre_delete_all_records() or return } + my $sth = $self->{driver}->delete() or return; + if ($self->_weight_cols()) { $self->_get_indexer()->post_delete_all_records($tmp_weights) or return } + + $sth; +} +END_OF_SUB + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ------------------------------------------------------------------- +# Just performs the query and returns a fetchall. +# + return shift->_query(@_)->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ------------------------------------------------------------------- +# Just performs the query and returns an active sth. +# + return shift->_query(@_); +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ------------------------------------------------------------------- +# Parses the input, and runs a select based on input. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF or CGI) only.'); + $self->name or return $self->fatal('NOTABLE'); +# Clear errors. + $self->{_error} = []; + +# Strip out values that are empty or blank (as query is generally derived from +# cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts; + $opts = \%input; + +# If build_query_cond returns a GT::SQL::Search object, then we are done. + my $cond = $self->build_query_cond($opts, $self->{schema}->{cols}); + + if ( ( ref $cond ) =~ /(?:DBI::st|::STH)$/i ) { + return $cond; + } + +# If we have a callback, then we get all the results as a hash, send them +# to the callback, and then do the regular query on the remaining set. + if (defined $opts->{callback} and (ref $opts->{callback} eq 'CODE')) { + my $pk = $self->{schema}->{pk}->[0]; + my $sth = $self->select($pk, $cond) or return; + my %res = map { $_ => 1 } $sth->fetchall_list; + my $new_results = $opts->{callback}->($self, \%res); + $cond = GT::SQL::Condition->new($pk, 'IN', [keys %$new_results]); + } + +# Set the limit clause, defaults to 25, set to -1 for none. + my $in = $self->_get_search_opts($opts); + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1; + +# Now do the select. + my @sel = (); + if ($cond) { push @sel, $cond } + if ($opts->{rs} and $cond) { push @sel, $opts->{rs} } + my $sth = $self->select(@sel) or return; + + return $sth; +} +END_OF_SUB + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want append to your search. +# Select options will be used for delete, and select. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_; + wantarray ? @{$self->{sel_opts}} : $self->{sel_opts}; +} + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that you wish returned. If none are +# specified all fields will be returned. +# + my $self = shift; + my $sel_opts = $self->{sel_opts} || []; + $self->{sel_opts} = []; + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Get the list of select fields. + my (@fields); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_} } + elsif (not ref $_) { push @fields, $_ } + } + @fields = grep defined && length, @fields; +# Extract the where clause and save it for future. + my ($where, $do_select) = _extract_where(@_); + $self->{last_where} = $where; + +# Perform the select + my $sth = $self->{driver}->select(\@fields, $where, $sel_opts) or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it. + $sel_opts = join " ", @$sel_opts; + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined $3) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif (defined $4) { # Pg-style with OFFSET before LIMIT + ($offset, $limit) = ($4, $5); + } + else { + ($limit, $offset) = ($1, $2 || 0); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + return $sth; +} + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# get() +# IN : primary key and format options, and fields wanted. +# OUT: array_ref/hash_ref on success, undef on failure. +# + my $self = shift; + +# Connect to the database if we are not already connected + $self->connect or return; + + my (@keys, @pk, @sel, $cond, $method, $format, $cols); + $self->name or return $self->fatal('NOTABLE'); + $cond = GT::SQL::Condition->new; + + if (@_ == 0) { return $self->fatal(BADARGS => 'Usage: $obj->get(HASH or HASH_REF or CGI_OBJ)') } + elsif (ref $_[0] eq 'HASH') { + my $href = shift; + for (keys %{$href}) { + $cond->add($_, '=', $href->{$_}); + } + } + else { + @keys = ref $_[0] eq 'ARRAY' ? @{shift()} : (shift); + @pk = @{$self->{schema}->{pk}}; + while (@keys) { + $cond->add(shift(@pk), '=', shift(@keys)); + } + } + + $format = uc shift || 'HASH'; + $cols = shift || []; + $method = $format eq 'ARRAY' ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond, $cols); + if ($sth) { + return $sth->$method(); + } + else { + return; + } +} +END_OF_SUB + +sub do_query { +# ----------------------------------------------------------- +# $obj->do_query($query) +# $obj->do_query($query, \@args); +# ------------------------ +# Performs SQL $query and returns a +# Query object as the result of this query. +# + my ($self, $query, $args) = @_; + + $self->connect or return; + $query = $self unless (ref $self || $query); + +# Show the query if debug is on. + $self->debug("Query: $query\n") if $self->{_debug} > 1; + +# Do the query. + my $sth = $self->{driver}->prepare($query) or return; + if ($args and ref $args eq 'ARRAY') { + $sth->execute(@$args) or return; + } + else { + $sth->execute or return; + } + $self->{sel_opts} = []; + return $sth; +} + +$COMPILE{do} = __LINE__ . <<'END_OF_SUB'; +sub do { + my $self = shift; + return $self->do_query(@_); +} +END_OF_SUB + +$COMPILE{reindex} = __LINE__ . <<'END_OF_SUB'; +sub reindex { +# ----------------------------------------------------------- +# $obj->reindex() +# ----------------------------------- +# Reindexes the database if required +# + my $self = shift; + my $opts = shift; + + $self->connect or return; + my $Indexer = $self->_get_indexer(); + $Indexer->reindex_all( $self, $opts ); +} +END_OF_SUB + +$COMPILE{indexing} = __LINE__ . <<'END_OF_SUB'; +sub indexing { +# ----------------------------------------------------------- +# $obj->indexing(0/1); +# -------------------- +# Enables/Disables indexing, spans life of object. +# + @_ == 2 and ($_[0]->{_index} = $_[1]); + return $_[0]->{_index}; +} +END_OF_SUB + +$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB'; +sub prepare { +# ----------------------------------------------------------- +# Passes query straight through to dbh. +# + my ($self, $query) = @_; + $self->connect or return; + return $self->{driver}->prepare($query); +} +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns the name of the current table instance. +# +# $obj->name($table_name); +# ------------------------- +# Sets the name for the table to create. +# + my $self = shift; + if (defined $_[0]) { + my $name = shift; + my $prefix = $self->{connect}->{PREFIX}; + if (length $prefix) { + unless ($name =~ /^$prefix/) { + $name = $prefix . $name; + } + } + unless ($name =~ /^(\w+)$/) { + return $self->fatal(BADNAME => $name); + } + $self->{name} = $1; + + # If a schema exists, a new GT::Config object is needed as the name just changed + $self->_new_schema if $self->{schema}; + } + return $self->{name}; +} + +# -------------------------------------------------------------------------------------- # +# ACCESSOR METHODS # +# -------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the hash structure for this tables +# cols. +# +# $obj->cols($hash_ref); +# ---------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols($array_ref); +# ----------------------- +# Just like $hash_ref, except an array ref. The array should look like: +# [ $col_name => { type => 'int' } ]. The difference between this and +# using a hash reference is that with the array ref pos will be automatically +# calculated and set in each column definition. The following two lines passed +# to cols() are equivelant and internally become the same thing: +# +# { $col1 => { type => 'int', pos => 1 }, $col2 => { type => 'text', pos => 2 } } +# [ $col1 => { type => 'int' }, $col2 => { type => 'text' } ] +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# ---------------------- +# Sets the relations columns as specified via method +# params. +# + my $self = shift; + + if (@_) { + if (@_== 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{cols} = $arg; + } + elsif (ref $arg eq 'ARRAY' and not @$arg % 2) { + for (0 .. 0.5 * @$arg - 1) { + $arg->[2 * $_ + 1]->{pos} = $_ + 1; + } + $self->{schema}->{cols} = {@$arg}; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->cols(HASH_REF or ARRAY_REF or HASH)'); + } + } + elsif (not @_ % 2) { $self->{schema}->{cols} = {@_} } + else { return $self->fatal(BADARGS => 'Usage $obj->cols(HASH_REF or ARRAY_REF or HASH)') } + + my $name = $self->{name}; + for (keys %{$self->{schema}->{cols}}) { + ref $self->{schema}->{cols}->{$_} eq 'HASH' or return $self->fatal(BADARGS => 'You must have a hash of hashes to specify your columns'); + exists $self->{schema}->{cols}->{$_}->{type} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no type defined."); + exists $self->{schema}->{cols}->{$_}->{pos} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no position defined."); + } + } + + return $self->{schema}->{cols} unless wantarray; + +# Wantarray has been set so create a copy of the cols whose +# first and second level references can be clobbered. +# This assumes that the values side of the schema will +# always been hashrefs + my %cols_copy = %{$self->{schema}{cols}}; + for my $col_name (keys %cols_copy) { + + my %col_data = %{$cols_copy{$col_name}}; + $cols_copy{$col_name} = \%col_data; + + for (keys %col_data) { + if (ref $col_data{$_} eq 'HASH') { + $col_data{$_} = {%{$col_data{$_}}}; + } + elsif (ref $col_data{$_} eq 'ARRAY') { + $col_data{$_} = [@{$col_data{$_}}]; + } + } + } + + return %cols_copy; +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# Returns the primary key columns for the current table. In scalar context, +# returns undef to indicate no primary key, or an array reference of column +# names. In list context you get a list of column names, or an empty list if +# no primary key exists. +# +# $obj->pk($array_ref); +# ---------------------- +# Sets relation primary key, $array_ref is the reference to an array which +# looks like: +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# --------------------------------- +# Sets relation primary key given the fields which are in parameter. +# + my $self = shift; + my @pk; + if (@_ == 0) { + my @pk = @{$self->{schema}->{pk}}; + return wantarray ? @pk : @pk ? \@pk : undef; + } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + push @pk, @{$arg}; + } + elsif (not ref $arg) { + push @pk, $arg; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in $arg"); + } + } + else { + for (@_) { + if (not ref $_) { + push @pk, @_; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in @_"); + } + } + } + @{$self->{schema}->{pk}} = @pk; + return wantarray ? @{$self->{schema}->{pk}} : $self->{schema}->{pk}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# $obj->ai; +# --------- +# Returns the auto incriment column for the current +# table instance. +# +# $obj->ai($column); +# ------------------- +# Sets the AUTO INCREMENT column. +# + my ($self, $ai) = @_; + ref $ai and return $self->fatal(BADARGS => "Argument to ->ai cannot be a reference"); + $self->{schema}->{ai} = $ai if defined $ai; + return $self->{schema}->{ai} +} +END_OF_SUB + +$COMPILE{search_driver} = __LINE__ . <<'END_OF_SUB'; +sub search_driver { +# ----------------------------------------------------------- +# $obj->search_driver; +# -------------------- +# Returns the search driver column for the current +# table instance. +# +# can be 'INTERNAL', 'MYSQL', 'NONINDEXED' +# +# $obj->search_driver($column); +# ----------------------------- +# Sets the Searching Driver column. +# + my ($self, $search_driver) = @_; + $search_driver and ref $search_driver and return $self->fatal(BADARGS => "Argument to ->search_driver must not be a reference"); + $self->{schema}->{search_driver} = $search_driver if $search_driver; + if ( not defined $self->{schema}->{search_driver} ) { + my $indexer = $self->_get_indexer(1); + ( ref $indexer ) =~ /::(\w+)::Indexer$/; + $self->{schema}->{search_driver} = $1; + } + return $self->{schema}->{search_driver}; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns a hash in list context and a hash ref +# in scalar context. This hash contain the index +# name as the keys and an array ref as the values. +# The array ref contains the fields that are part of +# the index that is the key. +# +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{index} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->index(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->index(HASH_REF) or $obj->index') + } + } + else { + my $index_name = shift; + $self->{schema}->{index}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{index}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{index}}) { + ref $self->{schema}->{index}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index}; +} +END_OF_SUB + +sub subclass { +# ----------------------------------------------------------- +# $obj->subclass; +# --------------- +# Returns the subclass for the current table. +# This subclass is what the objects are blessed +# into. This makes it easy to subclass per table object. +# +# $obj->subclass($subclass); +# --------------------------- +# Sets the subclass. $subclass should be a hash +# reference or a hash. +# + my $self = shift; + my $opt; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{subclass}} : $self->{schema}->{subclass} } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift } + elsif (defined $_[0] and @_ % 2 == 0) { $opt = {@_} } + else { return $self->fatal(BADARGS => 'Usage: $obj->subclass(HASH or HASH_REF)') } + + for my $meth (qw/html relation table/) { + next unless exists $opt->{$meth}; + if (ref $opt->{$meth} ne 'HASH') { + return $self->fatal(BADARGS => 'The hash that is passed into subclass() must be a hash of hashes'); + } + my $val = {}; + my $prefix = $self->{connect}->{PREFIX}; + for (keys %{$opt->{$meth}}) { + my $v = $_; + if (length $prefix) { + unless (/^$prefix/) { + $v = $prefix . $v; + } + } + $val->{$meth}->{$v} = $opt->{$meth}->{$_}; + } + $self->{schema}->{subclass}->{$meth} = $val->{$meth}; + } + return 1; +} + +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns a hash in list context and a hash ref +# in scalar context. This hash contains the unique +# index names as the keys and array refs as the values. +# The array refs contain the fields that are part of +# the unique index. +# +# $obj->unique($index_name, $col1, ..., $coln); +# --------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{unique} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->unique(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->unique(HASH_REF) or $obj->unique') + } + } + else { + my $index_name = shift; + $self->{schema}->{unique}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{unique}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{unique}}) { + ref $self->{schema}->{unique}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + + return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique}; +} + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# Returns a hash in list content and a hash ref in scalar +# context. This hash ref contains the foreign table as the +# key and a hash ref as the value. The hash ref has keys as +# the field in the current table that relates to fields in +# the foreign table. The values are the fields in the foreign +# table that the fields in this table relate to. +# +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_2, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ---------------------------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +# + my $self = shift; + @_ or return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; + + my %set; + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + %set = %$arg; + } + else { + return $self->{schema}->{fk}->{$arg}; + } + } + elsif (@_ == 2 and ref $_[1] eq 'HASH') { + %set = @_; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->fk(TABLE_NAME, HASH_REF or HASH_REF) or $obj->fk'); + } + my $prefix = $self->{connect}->{PREFIX}; + for my $table (keys %set) { + my $prefixed = $table; + $prefixed = $prefix . $prefixed if length $prefix and $table !~ /^\Q$prefix/; + $self->{schema}->{fk}->{$prefixed} = $set{$table}; + } + +# Make sure the arguments passed in were correct. + for my $ftable (keys %{$self->{schema}->{fk}}) { + ref $self->{schema}->{fk}->{$ftable} eq 'HASH' or return $self->fatal(BADARGS => "fk must contain a hash of hashes"); + } + + $self->_update_fk_tables or return; + + return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# Used to set the tables that reference this one. +# + my $self = shift; + if (@_ == 0) { return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables} } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + $self->{schema}->{fk_tables} = [@$arg]; + } + else { + @{$self->{schema}->{fk_tables}} = ($arg); + } + } + else { + @{$self->{schema}->{fk_tables}} = @_; + } + for (@{$self->{schema}->{fk_tables}}) { + if (ref $_) { + return $self->fatal(BADARGS => "Arguments to fk_table must be scalars"); + } + } + my $prefix = $self->{connect}->{PREFIX}; + for (@{$self->{schema}->{fk_tables}}) { + if (length $prefix) { + unless (/^$prefix/) { + $_ = $prefix . $_; + } + } + } + return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables}; +} +END_OF_SUB + +$COMPILE{tree} = __LINE__ . <<'END_OF_SUB'; +sub tree { +# ----------------------------------------------------------- +# An accessor for the GT::SQL::Tree object associated with +# this table. Creating/dropping a tree is done through the +# table editor. If no tree exists, you get undef and a warning +# occurs. + my $self = shift; + return $self->warn(NOTREE => $self->name()) unless ($self->{schema}->{tree}); + if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"}) { + $self->debug("Returning GT::SQL::Tree object for table $self->{name} from cache") if $self->{_debug}; + return $cached; + } + + require GT::SQL::Tree; + $self->debug("Creating new GT::SQL::Tree object for table " . $self->name()) if $self->{_debug}; + my $tree = GT::SQL::Tree->new({ + table => $self, + debug => $self->{_debug} + }); + + if ($self->{connect}->{obj_cache}) { + $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"} = $tree; + } + + return $tree; +} +END_OF_SUB + +$COMPILE{check_schema} = __LINE__ . <<'END_OF_SUB'; +sub check_schema { +# ----------------------------------------------------------- +# Checks the current table schema for inconsistencies in the +# structure. +# + my $self = shift; + my %cols = %{$self->{schema}->{cols}}; + +# Go through each column and check them + for my $col (keys %cols) { +# Make sure we have a position field. + if (! exists $cols{$col}->{pos}) { + $self->debug("Trying to create a column that does not have a position field.") if $self->{_debug}; + return $self->fatal(NOPOS => $col); + } + +# Primary key cannot be a "text" or "blob" type and must be "not null". + if ($self->_is_pk($col)) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("Trying to use a primary key without making it not null. Adding not_null to $col") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(PKTEXT => $col); + } + } + +# Unique must be "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{unique}}) { + if (grep /^\Q$col\E$/, @{$self->{unique}->{$_}}) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("unique key $col is not NOT_NULL. Adding to NOT_NULL") if ($self->{_debug}); + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(UNIQTEXT => $col); + } + } + } + +# Index must ne "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{index}}) { + if (grep /^\Q$col\E$/, @{$self->{schema}->{index}->{$_}}) { + unless ($self->_is_not_null($col)) { + $self->debug("index key $col is not NOT_NULL. Adding to NOT_NULL") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(INDXQTEXT => $col) if $self->{_debug}; + } + } + } + +# Autoincrement must be an "INT" type and must be the only "PRIMARY KEY" + $self->{schema}->{ai} ||= ''; + if ($col eq $self->{schema}->{ai}) { + if ($cols{$col}->{type} !~ /INT/i) { + return $self->fatal(AINOTPK => $col); + } + if (!$self->_is_pk($col) or @{$self->{schema}->{pk}} > 1) { + $self->debug("AUTO_INCREMENT column $col specified but is not the primary key. Making $col primary key.") if $self->{_debug}; + @{$self->{schema}->{pk}} = ($col); + } + } + +# File columns must point to exisiting directories where we have write access! + if ($cols{$col}->{form_type} and uc $cols{$col}->{form_type} eq 'FILE') { + $cols{$col}->{file_save_in} or return $self->fatal(NOFILESAVEIN => $col); + return $self->fatal(NODIRPRIV => $cols{$col}->{file_save_in}) + unless -w $cols{$col}->{file_save_in}; + } + } + +# Circularity check + $self->_circularity_check or return undef; + + return 1; +} +END_OF_SUB + +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { +# ----------------------------------------------------------- +# $obj->ordered_columns; +# ---------------------- +# Returns the current table columns ordered +# in function of the "pos" type of a given +# column. +# +# The columns having no specified pos are +# appended in lexicographical order at the +# end of the result array. +# + my $self = shift; + my @cols = (); + my @append = (); + my $cols = $self->{schema}->{cols}; + for my $col (sort { + $cols->{$a}->{pos} && $cols->{$b}->{pos} ? $cols->{$a}->{pos} <=> $cols->{$b}->{pos} : + $cols->{$a}->{pos} && !$cols->{$b}->{pos} ? -1 : + $cols->{$b}->{pos} && !$cols->{$a}->{pos} ? 1 : + ($a cmp $b) + } keys %{$cols}) { + push @cols, $col; + } + + return @cols; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + my @keys = map { @$_ } values %{$self->unique}, values %{$self->index}; + return wantarray ? @keys : \@keys; +} +END_OF_SUB + +$COMPILE{save_def} = __LINE__ . <<'END_OF_SUB'; +sub save_def { shift->save_state(@_) } +END_OF_SUB + +$COMPILE{save_state} = __LINE__ . <<'END_OF_SUB'; +sub save_state { +# ----------------------------------------------------------- +# $obj->save_state; +# ---------------------------- +# Saves table structure in $self->{connect}->{def_path}/table.def, and +# deletes the table from the object cache. +# + my $self = shift; + $self->debug("Saving state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + $self->{schema}->save(); + $self->debug("State saved for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + + my $cache_key = join("\0", 'TABLE', $self->{name}, $self->{connect}->{def_path}); + delete $GT::SQL::OBJ_CACHE{$cache_key}; + + return 1; +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# ------------------------------------------------------------------- +# $obj->file('ColumnName', $primary_key); +# ------------------------------ +# Returns the file associated with the column +# + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->file_info(@_); +} +END_OF_SUB + +$COMPILE{file_rescan} = __LINE__ . <<'END_OF_SUB'; +sub file_rescan { +# ------------------------------------------------------------------- + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->rescan(); +} +END_OF_SUB + +sub check_values { +# ------------------------------------------------------------------- +# Checks to see that the values for an insert are legal to +# be inserted. Returns false on error true on success +# + my ($self, $set) = @_; + +# Check to ensure the values are valid + my %cols = %{$self->{schema}->{cols}}; + my $ai = $self->{schema}->{ai}; + for my $col (keys %$set) { + next if ($ai and $ai eq $col); + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join $GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}; + } + $self->_check_value($col, $cols{$col}, $set->{$col}); + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +# -------------------------------------------------------------------------------------- # +# PRIVATE FUNCTIONS # +# -------------------------------------------------------------------------------------- # +$COMPILE{_update_fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub _update_fk_tables { +# ------------------------------------------------------------------- +# Updates all the tables fields that +# this tables is referenced by. +# + my $self = shift; + for my $table (keys %{$self->{schema}->{fk}}) { + my $foreign_table = $table eq $self->{name} + ? $self + : ($self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error)); + $foreign_table->_add_fk_table($self->{name}) + and $foreign_table->save_state(); + } + return 1; +} +END_OF_SUB + +$COMPILE{_add_fk_table} = __LINE__ . <<'END_OF_SUB'; +sub _add_fk_table { +# ----------------------------------------------------------------------------- +# Takes a foreign table name. The foreign table is added if it doesn't already +# exist in $self's fk_tables schema. Any duplicates are removed. This is to +# prevent the same table appearing several times in fk_tables. You still need +# to ->save_state() after calling this. Returns 1 if anything changed, undef +# otherwise. +# + my ($self, $add) = @_; + my %have = map { $_ => 1 } @{$self->{schema}->{fk_tables}}; + push @{$self->{schema}->{fk_tables}}, $add unless $have{$add}; + return $have{$add} ? undef : 1; +} +END_OF_SUB + +$COMPILE{_circularity_check} = __LINE__ . <<'END_OF_SUB'; +sub _circularity_check { +# ------------------------------------------------------------------- +# This function loops through all the tables in the current +# databases. If a circular reference is detected, then a +# warning is printed and FALSE is returned. If no circular +# references are detected, TRUE is returned. +# + my $self = shift; + my (%cols, @tables, %tables); + + return 1 unless keys %{$self->{schema}->{fk}}; # If there are no foreign keys there is nothing to do. + + my $name = $self->name; + + @tables = $name; + $tables{$name}++; + + for (my $i = 0; $i < @tables; $i++) { + return $self->fatal('CIRCULARLIMIT') if $i >= 100; + + my $table = $tables[$i]; + my $new = ($table eq $name) ? $self : $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + for my $table_name (keys %{$new->{schema}->{fk}}) { + my %this; # Allows for multiple fk's from the same table to the same key + for my $column (keys %{$new->{schema}->{fk}->{$table_name}}) { + my $tc = "$table: $table_name.$new->{schema}->{fk}->{$table_name}->{$column}"; + $self->debug("Found foreign key in $tc") if $self->{_debug}; + if (not $this{$tc}++ and $cols{$tc}++) { + $self->debug("$tc was already found!") if $self->{_debug}; + return $self->warn(CIRCULAR => $tc); + } + splice @tables, $i + 1, 0, $table_name unless $tables{$table_name}++; + } + } + } + + return 1; +} +END_OF_SUB + + +$COMPILE{_check_timestamp} = __LINE__ . <<'END_OF_SUB'; +sub _check_timestamp { +# ------------------------------------------------------------------- +# Won't modify a record if the passed in timestamp is older then +# what's in the database. +# + my ($self, $keys, $set) = @_; + +# first check to see if we even need to look up the orig timestamp. + my $auto = $self->time_check; + return 1 unless ($auto); + my $found = 0; + for (keys %$auto) { + exists $set->{$_} and ($found = 1); # should only be one timestamp. + } + return 1 unless ($found); + +# if we got here, then we do a search on the record and compare timestamp. + my $pk = $self->{schema}->{pk}; + my $cond = GT::SQL::Condition->new; + my @res; + for my $key (@$pk) { + $cond->add($key, "=", $keys->{$key}); + } + for my $tmstmp (keys %$auto) { + push @res, $tmstmp; + $cond->add($tmstmp, ">", $set->{$tmstmp}); + delete $set->{$tmstmp}; + } + my $sth = $self->select($cond, \@res) or return; + if ($sth->fetchrow_arrayref) { + return $self->warn('ALREADYCHANGED'); + } + else { + return 1; + } +} +END_OF_SUB + +sub _check_insert { +# ------------------------------------------------------------------- +# Check to make sure an insert is properly set up. +# + my ($self, $set, $cond) = @_; + my @indexes; + my %indx_hash = $self->unique; + push @indexes, values %indx_hash if (keys %indx_hash); + +# Add the primary key to the list of uniques + if (@{$self->{schema}->{pk}} and ! $self->{schema}->{ai}) { + push @indexes, $self->{schema}->{pk}; + } + +# Check to make sure that not_null columns without defaults have been specified + while (my ($c, $col) = each %{$self->{schema}->{cols}}) { + my $default = $col->{default}; + next unless exists $set->{$c}; + if ((not defined $set->{$c} or $set->{$c} eq '') and + ($col->{not_null}) and # Only check for not_null columns + (not $self->{schema}->{ai} or $c ne $self->{schema}->{ai}) and # But not the auto-increment field + (not defined $default or $default eq '')) { # And only when there isn't a default + $self->warn(NOTNULL => $col->{form_display} || $c); + } + } + +# Check that the unique columns are really unique. + my $check = {}; + INDEX: for my $index (@indexes) { + my $check = {}; + COL: for my $col (@$index) { + next INDEX if ($col eq $self->{schema}->{ai}); + $check->{$col} = $set->{$col}; + } + my $rows = $self->count($check); + if ($rows) { + $self->warn(UNIQUE => join(",", map $self->{schema}->{cols}->{$_}->{form_display} || $_, keys %$check), join(",", values %$check)); + } + } +# Check the values to make sure they are ok. + $self->check_values($set); + +# Join the list of errors. + my @errors = (ref($self->{_error}) and @{$self->{_error}}) ? @{$self->{_error}} : (); + if (@errors) { + $GT::SQL::error = join "\n", @errors; + return; + } + return 1; +} + +sub _check_update { +# ------------------------------------------------------------------- +# Checks to see if any of the set options +# are unique. If they are does a select +# on the table. If the condition tests +# true returns undef. The error will be set in +# the package error variable. +# + my ($self, $set, $cond) = @_; + +# Turn off warning here (too much work to remove unitilized values from +# returned data). + local $^W = 0; + +# Ensure that columns that are NOT NULL have not been specified as null + my %cols = %{$self->{schema}->{cols}}; + for my $col (keys %{$set}) { + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}); + } + $self->_check_value($col, $cols{$col}, $set->{$col}) or return; + } + my %indx_hash = $self->unique; + my @indexes = values %indx_hash; + +# Add the primary key to the list of uniques + my $pk = $self->{schema}->{pk}; + $pk = ref $pk ? $pk : [$pk]; + push @indexes, $pk unless $self->{schema}->{ai}; + +# If there are no uniques, then return previous errors, or return 1. + if (! @indexes) { + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } + } + my @marked = (); + +# Only request what has changed plus the primary key and any uniques + my %changes = (); + for (keys %$set) { $changes{$_} = 1 } + for (@$pk) { $changes{$_} = 1 } + for my $index (@indexes) { + for (@$index) { + $changes{$_} = 1; + } + } + +# Fetch records to make sure we don't break a unique clause. + my $sth = $self->select(keys(%changes), $cond) or return; + RECORD: while (my $rec = $sth->fetchrow_hashref) { + +# Go through all the indexes for this table + for my $i (0 .. $#indexes) { + +# A hash to build the count query out of + my $count_check = {}; + +# If the record is different than the one in the database + my $match = 0; + for (@{$indexes[$i]}) { + if (defined $set->{$_} and $set->{$_} ne $rec->{$_}) { + $match = 1; + } + $count_check->{$_} = $set->{$_}; + } + +# It was not different so we continue to the next set of uniques + $match or next; + +# It was different so we need to make a count select to see if it is possible +# to do this insert + if ($self->count($count_check)) { + +# the count returned true so there was a duplicate record + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# The count returned false so there was not a duplicate record +# so if the record is already marked we return false + if ($marked[$i]) { + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# else we mark the record. + $marked[$i] = 1; + } + } + } + } + +# Everything should have went fine so return true the record is +# insertable. + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } +} + +sub _check_value { +# ------------------------------------------------------------------- +# Checks to see if a value is valid. +# + my ($self, $name, $column, $value) = @_; + + my $regex = ''; + if ($column->{not_null} and (not defined $value or $value eq '')) { + $self->warn(NOTNULL => $column->{form_display} || $name); + } + if ($column->{type} eq 'ENUM' and $value) { + $regex = '^(?:' . join('|', map quotemeta, @{$column->{values}}) . ')$'; + } + elsif (defined $value) { + unless ($regex = $column->{regex}) { + if ($column->{type} eq 'INTEGER' or $column->{type} =~ /INT$/) { + $regex = '^[+-]?\d+$'; + } + elsif ($column->{type} =~ /^(?:REAL|FLOAT|DOUBLE|DECIMAL)$/) { + $regex = '^[+-]?(?=\d|\.\d)\d*(\.\d*)?(?:[eE][+-]?\d+)?$'; + } + } + } + + if ($regex and not ref $value) { + if (eval { $value !~ /$regex/ }) { + $self->warn(ILLEGALVAL => $column->{form_display} || $name, $value); + } + elsif ($@) { + $self->warn(REGEXFAIL => $regex); + } + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +sub _extract_where { +# ------------------------------------------------------------------- +# Takes the users input and extracts the +# hash refs or condition clause. Creates +# a Condition object and returns it. +# Returns where the query was a hash or not +# as well. +# + my @args = @_; + my $cond = GT::SQL::Condition->new; + my $do_select = 0; + for (@args) { + if (ref eq "HASH") { + while (my ($col, $val) = each %$_) { + $cond->add($col => '=' => $val); + } + } + elsif (ref eq 'GT::SQL::Condition') { + $do_select = 1; + $cond->add($_->clone); + } + } + return ($cond, $do_select); +} + +sub _build_cond { +# ------------------------------------------------------------------- +# this subroutine is done to build conditions +# which may not be a Condition +# for selects and deletes. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond->clone; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + for my $key (keys %{$cond}) { + next unless exists $cols->{$key}; + if (ref $cond->{$key} eq 'ARRAY') { + $tmp->add($key => IN => $cond->{$key}); + } + elsif (defined $cond->{$key}) { + $tmp->add($key => '=' => $cond->{$key}); + } + else { + $tmp->add($key => 'IS' => \'NULL'); + } + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition(@$cond); + return $tmp->clone; + } + $self->fatal(BADARGS => "_build_cond takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +sub _build_set { +# ------------------------------------------------------------------- +# Internal use. Builds the set options for the query. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + $tmp->bool(','); + for my $key (keys %{$cond}) { + $tmp->add($key, "=", $cond->{$key}) if exists $cols->{$key}; + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$cond}, ','); + return $tmp; + } + $self->fatal(BADARGS => "_build_set takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +$COMPILE{_check_keys} = __LINE__ . <<'END_OF_SUB'; +sub _check_keys { +# ------------------------------------------------------------------- +# Checks to see if the arguments passed into +# delete contains the externally linked columns +# + my ($self, $where) = @_; + ref $where or return $self->fatal(BADARGS => '_check_keys'); + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for ($self->fk_tables) { + my $new_schema = $self->new_table($_) or return $self->fatal(FKNOTABLE => $_, $GT::SQL::error); + my %hash = $new_schema->fk; + my $name = $self->name; + + for (values %{$hash{$name}}) { + return unless exists $cond->{$_}; + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_do_opt} = __LINE__ . <<'END_OF_SUB'; +sub _do_opt { +# ------------------------------------------------------------------- +# Does a select or delete based on the option +# + my ($self, $opt, $sel_hashr, $table_name) = @_; + my $new_me = $self->new_table($table_name) or return $self->fatal(FKNOTABLE => $table_name, $GT::SQL::error); + if ($opt eq 'cascade') { + my $cond; + if ($self->{schema}->{tree} and keys %$sel_hashr > 1 and $self->tree->{tree}->name() eq $new_me->name()) { + $cond = []; + for (keys %$sel_hashr) { + push @$cond, GT::SQL::Condition->new($_ => '=' => $sel_hashr->{$_}); + } + } + else { + $cond = $sel_hashr; + } + if (ref $cond eq 'ARRAY') { + for (@$cond) { + $new_me->delete($_) or return; + } + } + else { + $new_me->delete($cond) or return; + } + } + else { + return $self->warn(DEPENDENCY => $table_name) if $new_me->count($sel_hashr); + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cond} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cond { +# ------------------------------------------------------------------- +# Performs the delete based on a condition object +# + my ($self, $where, $opt) = @_; + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + while (my ($k, $v) = each %$fk_href) { + $sel_hashr->{$k} = $cond->{$v} if exists $cond->{$v}; + } + $self->_do_opt($opt, $sel_hashr, $fktable) or return; + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_select} = __LINE__ . <<'END_OF_SUB'; +sub _delete_select { +# ------------------------------------------------------------------- +# Performs the delete based on the cascade +# option +# + my ($self, $q, $opt) = @_; + my $fk_del; + my $data = $q->fetchall_hashref; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + for my $row (@$data) { + for my $fk (keys %$fk_href) { + push @{$sel_hashr->{$fk}}, $row->{$fk_href->{$fk}}; + } + } + $self->_do_opt($opt, $sel_hashr, $fktable) or return if keys %$sel_hashr; + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cleanup} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cleanup { +# ------------------------------------------------------------------- +# Performs the delete based on one to many relationship. +# + my ($self, $where) = @_; + +# Get the SQL. + my $sth = $self->select($where); + + my $rows = $sth->fetchall_arrayref(); + return 0 unless $rows and @$rows; + + $sth = $self->{driver}->delete($where) or return; + + my $name = $self->name; + for my $fk_table ($self->fk_tables) { + + my $new_schema = $self->new_table($fk_table) or return $self->fatal(FKNOTABLE => $fk_table, $GT::SQL::error); + my %fk = $new_schema->fk; + my @ls = sort keys %{$fk{$name}}; + my $rel = $self->new_relation($fk_table, $self->name); + my %cond; + for my $col (@ls) { + my $c = $fk{$name}->{$col}; + $cond{"$name.$c"} = undef; + my @sel_limit = map $_->[$self->{schema}->{cols}->{$c}->{pos} - 1], @$rows; + next unless @sel_limit; + $cond{"$fk_table.$col"} = \@sel_limit; + } + my $sth = $rel->select('left_join', @ls, \%cond) or return; + my $cols = $new_schema->cols; + + my $pk_vals = $sth->fetchall_arrayref; + if (@ls > 1) { + for my $row (@$pk_vals) { + $new_schema->delete({ map { ($ls[$_] => $row->[$_]) } 0 .. $#ls }) or return; + } + } + elsif (@ls == 1) { + my @del = map $_->[0], @$pk_vals; + $new_schema->delete({ $ls[0] => \@del }) if @del; + } + } + return 1; +} +END_OF_SUB + +# Returns a hash of all columns that have positive weights. +$COMPILE{_weight_cols} = __LINE__ . <<'END_OF_SUB'; +sub _weight_cols { + my $self = shift; + return map { + $self->{schema}->{cols}->{$_}->{weight} + ? ($_ => $self->{schema}->{cols}->{$_}->{weight}) + : () + } keys %{$self->{schema}->{cols}}; +} +END_OF_SUB + +# a hash of all columns that have form_type file +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { + my $self = shift; + $self->{_file_cols} = { + map { + ($self->{schema}->{cols}->{$_}->{form_type} and uc $self->{schema}->{cols}->{$_}->{form_type} eq 'FILE') + ? ($_ => $self->{schema}->{cols}->{$_}) + : () + } keys %{$self->{schema}->{cols}} + } if !$self->{_file_cols} or shift; + + %{$self->{_file_cols}}; +} +END_OF_SUB + +# Returns true if first argument is a primary key. +$COMPILE{_is_pk} = __LINE__ . <<'END_OF_SUB'; +sub _is_pk { + for (@{$_[0]->{schema}->{pk}}) { + return 1 if $_ eq $_[1]; + } + return 0; +} +END_OF_SUB + +$COMPILE{_is_fk} = __LINE__ . <<'END_OF_SUB'; +sub _is_fk { +# ------------------------------------------------------------------- +# Returns true if first argument is a foreign key. +# + for (keys %{$_[0]->{schema}->{fk}}) { + return 1 if exists $_[0]->{schema}->{fk}->{$_}->{$_[1]}; + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is not null. +$COMPILE{_is_not_null} = __LINE__ . <<'END_OF_SUB'; +sub _is_not_null { + return( + exists $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + and $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + ); +} +END_OF_SUB + +# Returns true if first argument is indexed. +$COMPILE{_is_indexed} = __LINE__ . <<'END_OF_SUB'; +sub _is_indexed { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{index}}) { + for my $index_col (@{$self->{schema}->{index}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is uniquely indexed. +$COMPILE{_is_unique} = __LINE__ . <<'END_OF_SUB'; +sub _is_unique { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{unique}}) { + for my $index_col (@{$self->{schema}->{unique}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if ($self->{_debug} > 2); + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self + ); + $indexer->debug_level($self->{_debug}); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Table - a perl interface to manipulate a single SQL table. + +=head1 SYNOPSIS + + my $sth = $table->select(Column3 => { Column => $value, Column2 => $value2 }); + $table->delete({ Column => $value }); + $table->insert({ Column1 => $val, Column2 => $value2 }); + $table->update({ SetCol => $val }, { WhereCol => $val2 }); + +=head1 DESCRIPTION + +GT::SQL::Table provides methods to add, modify, delete and search over a single +SQL table. + +The following methods are provided. + +=head2 query, query_sth + +C provides a simple and powerful method to search a table. It takes as +input either a hash, hash ref or CGI object making it especially useful +searching from web forms. + + my $results = $db->query($in); + +The return of C is an arrayref of arrayrefs. C returns an STH +that you can fetch rows from. + +Typical usage to go through the results is: + + my $results = $db->query({ Title => 'foobar' }); + if ($results) { + for my $result (@$results) { + ... + } + } + +To specify what to search, you simply pass in column => search value. However, +you can also pass in a lot of options to enhance your search: + +Find all rows with field_name = value: + + field_name => value + +Find all rows with field_name > value: + + field_name => ">value" + +Find all rows with field_name < value: + + field_name => " value: + + field_name-gt => value + +Find all rows with field_name < value: + + field_name-lt => value + +Find all rows where any field_name = value: + + keyword => value + +Find all rows using indexed search (see weights): + + query => value + +Set to 1, use '=' comparison, 0/unspecified use 'LIKE '%val%' comparision: + + ww => 1 + +Search using LIKE for column 'Title' (valid opts are '=', '>', '<' or 'LIKE'): + + Title-opt => 'LIKE' + +Set to 1, OR match results, 0/unspecified AND match results: + + ma => 1 + +Return a max of n results, defaults to 25: + + mh => n + +Return page n of results: + + nh => n + +Sort by 'Title' column: + + sb => 'Title' + +Sort in ascending (ASC) or descending (DESC) order: + + so => 'ASC' + +=head2 select + +Select provides a way to implement almost any sql SELECT statement. + +An executed statement handle is returned that you can call the normal fetchrow, +fetchrow_array, fetchrow_hashref, etc on. + + my $sth = $obj->select; + +is equivalant to "SELECT * FROM Table" + + my $sth = $obj->select({ Col => Val }); + +is equivalant to "SELECT * FROM Table WHERE Col = 'Val'". + + my $sth = $obj->select('Col2', 'Col3', { Col => "Val" }); + +is equivalant to "SELECT Col2,Col3 FROM Table WHERE Col => 'Val'". + +So you can pass in a hash reference which represents the where clause, and an +array reference where represents what you want to select on. + +If you need more complex where clauses, you should use a condition object +instead of a hash reference. See L for more information. + +Notes: + +=over 4 + +=item quoting in where + +All arguments in the where clause are automatically quoted. If you don't want +quotes, you should pass in a scalar reference as in: + + my $sth = $obj->select({ Col => \"NOW()" }); + +which turns into "SELECT * FROM Table WHERE Col = NOW()". + +=item quoting in select + +Nothing in the select will be quoted, so to use functions, simply pass in what +you want: + + my $sth = $obj->select('COUNT(*)'); + +which turns into "SELECT COUNT(*) FROM Table". + +=back + +To specify LIMIT, or GROUP BY, or ORDER BY or other SELECT clauses that come +after the WHERE, you should use select_options below. + +=head2 select_options + +This method provides a way for you to specify select options such as LIMIT and +SORT_BY. + + $obj->select_options(@OPTIONS); + +@OPTIONS should be a list of options you want appended to your next select. + +For example, + + $obj->select_options('ORDER BY Foo', 'LIMIT 50'); + $obj->select; + +would turn into "SELECT * FROM Table ORDER BY Foo LIMIT 50". To perform a +LIMIT with an OFFSET, you should specify something like: + + $obj->select_options('LIMIT 25 OFFSET 75'); + +You can alternatively use the equivelant MySQL-specific syntax: + + $obj->select_options('LIMIT 75, 25'); + +Both will be handled correctly regardless of the database type. + +=head2 count + +This method will allow you to count records based on a where clause. + + my $count = $obj->count($condition); + +count() takes either a condition or a hash reference. If no argument is +provided, it is equivalant to "SELECT COUNT(*) FROM Table", or total number of +rows. + +=head2 hits + +This method returns the number of hits from that last select query B +the limit clause if there was one. + + $hits = $obj->hits; + +For example, to get rows 20-30 of a query result, use: + + $obj->select_options("LIMIT 10 OFFSET 20"); $obj->select({ Column => 'Foo' }); + +this translates into (in MySQL): + + SELECT * FROM Table WHERE Column = 'Foo' LIMIT 20, 10 + +To see the total number of results that the query would have retrieved without +any limit, you call: + + $hits = $obj->hits; + +If the number of hits can be calculated, it will be returned to you without any +additional query. Otherwise, the following query will be performed +automatically, and the hit count returned to you: + + SELECT COUNT(*) FROM Table WHERE Column = 'Foo' + +B: The hits() method _only_ applies to select queries. Most databases do +not provide enough information to get counts of rows affected for other types +of queries. + +=head2 get + +This method allows for a simple interface to retrieving records from the +table(s). + + my $rec_hash_ref = $obj->get($val); + my $rec_hash_ref = $obj->get($val, 'HASH', ['col1', 'col2']); + my $rec_array_ref = $obj->get($val, 'ARRAY'); + +The first argument is the primary key value of the record you want to retrieve. + +The second argument is a format option. It can be either 'ARRAY' or 'HASH' and +determines whether you are returned a HASH reference or an ARRAY reference. The +default is 'HASH', and it is optional. + +The last argument is a list of column names you want retrieved. C defaults +to returning the entire record, but if you only need specific columns, you can +ask for the ones you want. + +For example: + + my $employee = $emp_db->get('Alex'); + +would return a hash ref of the record whose primary key is equal to 'Alex'. + + my $emp_addr = $emp_db->get('Alex', 'HASH', ['City', 'State', 'ZipCode']); + +would return a hash ref of only the three fields City, State, ZipCode for the +record whose primary key equals Alex. + +=head2 add + +Method to add an entry into the database. This method can take it's arguments +one of three ways. + + $obj->add($CGI_OBJECT); + + -or- + + $obj->add({ + col1 => $val1, + col2 => $val2, + ... + }); + + -or- + + $obj->add( + col1 => $val1, + col2 => $val2, + ... + ); + +This method can take a cgi object, a hash reference or a hash. The keys of the +hash should be the names of the column and the values should be the values to +insert into the fields. The CGI Object is not different. If the table has an +auto_increment field, the value of the last inserted record will be returned. + +C returns undef on failure. If successful, and the table has an +auto-increment field, the auto increment value is returned. If there is no +auto increment value, then 1 is returned. Any errors will be in +$GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 will have the table module skip any error +checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 insert + +C is a lower level add. The main differences between C and +C are that add performs a not null check, and add returns the id of the +just inserted value. + +C does not perform a not null check. Also, insert returns the statement +handle used to do the insert (so you can call $sth->insert_id to get the auto +increment). + +=head2 insert_multiple + +C will try to optimize the insertion of multiple rows with +simple values. Under MySQL, this uses MySQL's extended insert syntax: + + INSERT INTO Table (col1, col2, col3) + VALUES ('val1', 'val2', 'val3'), ('val4', 'val5', 'val6'), ... + +On other databases, it attempts to perform all insertions in a single +transaction, which will also usually yield performance benefits. Note, +however, that C should not be used for anything more complex +than basic column values - for example, inserting NULL to set the current date, +or using raw SQL by passing scalar references for values. + +It takes at least two arguments - the first argument is an array ref of column +names, and the rest are array references of values. For example, to produce +the above example SQL code, you would call: + + $table->insert_multiple( + ['col1', 'col2', 'col3'], + ['val1', 'val2', 'val3'], + ['val4', 'val5', 'val6'], + ... + ); + +=head2 modify + +This method is designed for modifying a single entry in the table. It takes as +input a hash, hash ref or CGI object, which is assumed to represent a single +row with all fields intact. + +C will then look for the primary key in the input and set all fields +for that row equal to what was passed in. + +You need to pass in a complete record! If you just want to update one column, +you probably want to use C instead, as doing: + + my $result = $obj->modify(column1 => 'Foo'); + +will blank out all the other fields and set just column1 to Foo. + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 update + +This method provides a more robust way to update multiple entries in the table. + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + $condition + ); + + -or- + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + { + col1 => $val1, + col2 => $val2, + ... + } + ); + +In both these cases the first argument is a hash reference with the column +names as the keys and the new values you want the columns to hold as the +values. The second argument can either be a condition object or a hash +reference. If it is a hash reference the keys will be used as the column names +and the values will be taken as the current column values for the where clause +to update the table. + + $obj->update({ Setme => 'NewValue'}, { WhereCol => 5 }); + +would set the column 'Setme' to 'NewValue' where the column 'WhereCol' is 5. +This translates to: + + UPDATE Table SET SetMe='NewValue' WHERE WhereCol = 5 + +If the second argument is a GT::SQL::Condition object the condition object will +be used to build the where clause with. Please see L for a +description of what you can do with a where clause. + + my $condition = GT::SQL::Condition->new('WhereCol', 'LIKE', 'Foo%'); + $obj->update({ Setme => 'Newvalue' }, $condition); + +would translate to: + + UPDATE Table SET Setme = 'Newvalue' WHERE WhereCol LIKE 'Foo%' + +The condition can now much more complex where clauses though. + +C returns undef on failure and the a L statement +handle on success. The error message will be available in $GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 as a third option to C will have the +table module skip any error checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 delete + +This method provides a robust interface to delete entries from your table(s) +using join and or foreign key relations. + + my $result = $obj->delete($condition); + +You can pass into C either a condition object to delete multiple +entries, or a scalar value to delete the row whose primary key equals the +value. If you have a multiple primary key, then you can pass in an array ref to +delete that row. + + my $result = $obj->delete({ + col1 => $val1, + col2 => $val2, + ... + ); + + -or- + + $obj->delete($val); + + -or- + + $obj->delete([$val1, $val2]); + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 delete_all + +This method takes no arguments and will erase all entries from a table. + +=head2 Table Properties + +Table provides a lot of methods to access information about the table: + +=over 4 + +=item name + +Provides the name of the table minus any prefix. + +=item ai + +Returns the name of the auto-increment field if any. + +=item pk + +Returns an array(ref) of primary key column names. + +=item fk + +Returns a hash of foreign key values. + +=item fk_tables + +Returns a list of tables with foreign keys pointing to this table. + +=item index + +Returns a hash ref of index name => array ref of column names that index uses. + +=item unique + +Returns a hash ref of unique index names => array ref of column names that +unique index uses. + +=item B + +Returns the joined output of index and unique and primary key. + +=item cols + +Returns a hash(ref) of column name => column definition + +=item default + +Returns a hash(ref) of column name => default value. + +=item size + +Returns a hash(ref) of column name => size of column in SQL. + +=item type + +Returns a hash(ref) of column name => type of column in SQL. + +=item form_display + +Returns a hash(ref) of column name => name to display on auto generated forms +(think pretty name). + +=item form_size + +Returns a hash(ref) of column name => size of html form to generate. + +=item form_type + +Returns a hash(ref) of column name => type of html form to generate (checkbox, +select, text, etc). + +=item form_names + +Returns a hash(ref) of column name => array ref of form names. This is used for +multi option form elements like checkboxes and multi selects. The name is what +is displayed to the user and not entered in the database. + +=item form_values + +Returns a hash(ref) of column name => array ref of form values. Same as above, +but this is the value that actually gets entered. + +=item time_check + +Returns a hash(ref) of column name => time check on or off. If set + +=item regex + +Returns a hash(ref) of column name => regular expression that all input must +pass before being inserted. + +=item pos + +Returns a hash(ref) of column name => position in table. + +=item not_null + +Returns a hash(ref) of column name => not null (whether the field is allowed to +be null or not). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Table.pm,v 1.251 2005/02/28 20:37:41 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Tree.pm b/site/glist/lib/GT/SQL/Tree.pm new file mode 100644 index 0000000..6d651c9 --- /dev/null +++ b/site/glist/lib/GT/SQL/Tree.pm @@ -0,0 +1,1268 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : +# $Id: Tree.pm,v 1.29 2005/05/31 06:26:32 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to manage a tree structure in a table. +# +# +# The comments through this document reference "record hash refs" - +# a record hash ref consists of 5 keys: +# - tree_id_fk => the ID +# - tree_anc_id_fk => the ancestor ID +# - tree_dist => The 'distance' between the id and the ancestor. If the +# ancestor is the father, this is 1; for the grandfather, 2 +# +# Most things have a common return, which looks like this: +# { id => [{ record }, { record2 }, { record3 }], id2 => [], ... } +# Where id, id2, ... are the ID's you pass in, and record, record2, record3, ... +# are the record hash refs mentioned above with the relationship requested (parents, +# children, siblings, etc.) +# +package GT::SQL::Tree; +# =============================================================== +use strict; +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::SQL::Table; +use GT::AutoLoader; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants + TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + $self->{connect} = $self->{table}->{connect}; + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + my $tree_table = $self->{table}->name . "_tree"; # ->name returns the table _prefixed_ + my $name = $self->{connect}->{def_path} . '/' . $tree_table . '.def'; + -e $name or return $self->error(FILENOEXISTS => FATAL => $name); + + $tree_table = $self->new_table($tree_table); + + $self->{tree} = $tree_table; + + return $self; +} + +sub DESTROY {} + +$COMPILE{create} = __LINE__ . <<'END_OF_SUB'; +sub create { +# ----------------------------------------------------------- +# GT::SQL::Tree->create(...) +# Create a new table, $tablename . "_tree". +# The arguments are as follows: +# table => $table_obj, # This is the table object the tree is to be built upon. +# father => 'father_id_fk', # The column in the table that contains the father ID. It must already exist. +# root => 'root_id_fk', # The column in the table that contains the root ID. It must already exist. +# depth => 'rec_depth', # The column in the table that keeps track of the depth (below the root) of the record. +# +# Optional arguments: +# force => 'force', # Specifies to argument to GT::SQL::Creator->create. Typically, 'force' or 'check'. +# debug => $debug_level, # Specifies to debug level for the GT::SQL::Tree object. +# rebuild => $rebuild, # A GT::SQL::Tree::Rebuild object +# You'll get back a GT::SQL::Tree object, just as if you had called new() for +# a tree that already existed. +# +# The new table created will have the following keys: +# tree_id_fk : A foreign key to the primary key of the table passed in +# tree_anc_id_fk : Also a foreign key to the primary key, this one stores an ancestor of id_fk +# tree_dist : This stores the distance (levels) between the ID and the ancestor. +# +# To give an example of how this will all look, let's say we have a structure like this: +# a +# - b +# - c +# - d +# - e +# Where b and c are children of a, d is a child of c, and e is a child of d. +# There will be the normal records, one per element. So, the main table looks +# like this: +# +# +-------+------+--------------+------------+-----------+ +# | pk_id | name | father_id_fk | root_id_fk | rec_depth | +# +-------+------+--------------+------------+-----------+ +# | 1 | a | 0 | 0 | 0 | +# | 2 | b | 1 | 1 | 1 | +# | 3 | c | 1 | 1 | 1 | +# | 4 | d | 3 | 1 | 2 | +# | 5 | e | 4 | 1 | 3 | +# +-------+------+--------------+------------+-----------+ +# +# For this example, the associated tree table will look like this: +# +# +------------+----------------+-----------+ +# | tree_id_fk | tree_anc_id_fk | tree_dist | +# +------------+----------------+-----------+ +# | 2 | 1 | 1 | +# | 3 | 1 | 1 | +# | 4 | 3 | 1 | +# | 4 | 1 | 2 | +# | 5 | 4 | 1 | +# | 5 | 3 | 2 | +# | 5 | 1 | 3 | +# +------------+----------------+-----------+ +# +# This format allows GT::SQL::Tree to easily (one simply query) select all +# descendants or ancestors given an ID. +# +# Calling ->create() on a table with data may take quite some time as it will +# create a tree for that table. You can, however, use this to recreate the +# tree for a particular table. +# + my $class = shift; + my $input = $class->common_param(@_) or return $class->error(BADARGS => FATAL => 'GT::SQL::Tree->create(HASH or HASH REF)'); + + my $self = {}; + + bless $self, ref $class || $class; + $self->{_debug} = $input->{debug} if $input->{debug}; + + my $table = $input->{table}; + $table and $table->name or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., table => $table_obj, ...)'); + $input->{father} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., father => \'father_col\', ...)'); + $input->{root} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., depth => \'depth_col\', ...)'); + + $self->{connect} = $table->{connect}; + + $table->pk and @{$table->pk} == 1 or return $self->error(TREEBADPK => FATAL => $table->name); + + # If a rebuild object was passed in, let it do its stuff. + if ($input->{rebuild}) { + $input->{rebuild}->_rebuild($table->pk->[0], @$input{qw/root father depth/}); + } + + my $tree = $table->name . "_tree"; + + my $c = $self->creator($tree); + + $c->cols([ + tree_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'ID' }, + tree_anc_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Ancestor' }, + tree_dist => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Distance' } + ]); + + my $table_name = $table->name(); + $table_name =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $pk = $table->pk()->[0]; + $c->fk({ + $table_name => { tree_id_fk => $pk, tree_anc_id_fk => $pk } + }); + + $c->subclass({ + relation => { "${table_name}\0${table_name}_tree" => 'GT::SQL::Tree::Relation' } + }); + + my $tree_i_prefix = lc substr($table_name, 0, 4); + + $c->index({ + "${tree_i_prefix}_tri" => ['tree_id_fk'], + "${tree_i_prefix}_tra" => ['tree_anc_id_fk', 'tree_dist'] + }); + + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_ROOT] = $input->{root}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_FATHER] = $input->{father}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_DEPTH] = $input->{depth}; + + $self->debug("Creating tree table '$tree'") if $self->{_debug}; + my $ok = $c->create($input->{force} || 'force'); + + if (!$ok) { + if ($GT::SQL::errcode eq 'TBLEXISTS') { + $c->set_defaults(); + $c->save_schema(); + } + else { + return; + } + } + + $table->fk($table_name => { $input->{father} => $pk }); + + $table->{schema}->{tree} = 1; + $self->debug("Saving tree existance in parent schema") if $self->{_debug}; + $table->save_state(); + $self->{table} = $table; + $self->{tree} = $self->new_table($tree); + + return $self unless $ok and $table->count(); # $ok will be false if we were instructed NOT to overwrite the table + + # Uh oh, this is fun... it means we have to create the tree from the existing table. + $self->debug("$table_name already has rows; building new tree table data") if $self->{_debug}; + $self->{tree}->delete_all(); + + my ($root_col, $depth_col, $father_col) = ($self->root_id_col, $self->depth_col, $self->father_id_col); + + my $top = $table->select("MAX($pk)")->fetchrow; + my $count = $table->count(); + my $roots = $table->count($root_col => 0); + $self->debug("Building ancestor tree ...") if $self->{_debug}; + my ($j, %parents, %depth); # %parent = ( id => [parents], id => [parents], ... ), %depth = ( $id => $depth, $id => $depth, ... ) + + for (my $i = 0; $i < $top; $i += 500) { # Get 500 threads at a time + $table->select_options("ORDER BY $root_col, $depth_col"); + my $cond = GT::SQL::Condition->new($root_col => '>' => $i, $root_col => '<=' => $i + 500); + + my $sth = $table->select($pk, $root_col, $father_col, $depth_col => $cond); + + my $last_root = 0; + %parents = (); + while (my ($id, $root, $parent, $depth) = $sth->fetchrow) { + if ($parent == $root) { + $parents{$id} = [$parent]; + } + else { + $parents{$id} = [@{$parents{$parent} || []}, $parent]; + } + $depth{$id} = $depth; + $self->debug("Processed $j records...") if $self->{_debug} and (++$j % 5000) == 0; + } + my @inserts; + if (keys %parents) { + for my $id (keys %parents) { + for my $anc (@{$parents{$id}}) { + push @inserts, [$id, $anc, $depth{$id} - ($depth{$anc} || 0)]; + } + } + } + + $self->{tree}->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @inserts) if @inserts; + } + + $self->debug("$j non-root nodes found.") if $self->{_debug}; + + return $self; +} +END_OF_SUB + +$COMPILE{destroy} = __LINE__ . <<'END_OF_SUB'; +sub destroy { +# ----------------------------------------------------------- +# $obj->destroy +# Drops the tree for the table of the current object. + + my $self = shift; + my $c = $self->creator($self->{table}->name . "_tree"); + + $c->drop_table; + + delete $self->{table}->{schema}->{tree}; + $self->{table}->save_state(); + + return 1; +} +END_OF_SUB + +sub root_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_ROOT]; +} + +sub father_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_FATHER]; +} + +sub depth_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_DEPTH]; +} + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $tree->insert(insert_id => $inserted_id, data => $insert_hash); +# This will insert the approriate record into the tree table. +# $inserted_id should be the insert_id of the new record and +# $insert_hash should contain at least the father, root, and +# depth columns. +# The number of rows inserted into the tree table is returned +# on success. Note that 0 is returned as 0e0 for a root. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->insert(HASH or HASH_REF)'); + + my $table = $self->{tree} or return $self->error(NOTREEOBJ => FATAL => '$tree->insert()'); + + my $insert_id = $input->{insert_id}; + my $data = $input->{data}; + + my $f = $self->father_id_col; + + return "0e0" unless my $fid = $data->{$f}; # If there is no father, it's a root, so we don't do anything. + + my $parents = $self->parents(id => $fid); + + push @$parents, { tree_id_fk => $fid, tree_anc_id_fk => $fid, tree_dist => 0 }; # tree_id_fk isn't used, and dist will have one added to it to get the node-father row + + my @insertions; + for (@$parents) { + my ($anc, $depth) = @$_{'tree_anc_id_fk', 'tree_dist'}; + + push @insertions, [$insert_id, $anc, $depth + 1]; + } + $table->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @insertions); + + return scalar @insertions; +} +END_OF_SUB + +$COMPILE{pre_update} = __LINE__ . <<'END_OF_SUB'; +sub pre_update { +# ----------------------------------------------------------------------------- +# $tree->update(where => $condition, data => $update_hash); +# $update_hash should contain the father_id column. This should only be +# called (by GT::SQL::Table) when an update occurs that changes the +# father_id. $update_hash must be the hash reference that will be used for +# the update because it is going to be changed for the root and depth fields. +# You're going to get back some sort of data structure from this (subject to +# change). Pass the data structure into "update" after the update occurs +# successfully. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->update(HASH or HASH REF)'); + + my $update_hash = $input->{data} or return $self->error(BADARGS => FATAL => '$tree->update(... data => $update_hash ...)'); + + my $where = $input->{where} or return $self->error(BADARGS => FATAL => '$tree->update(... where => $condition ...)'); + + my ($pk, $r, $f, $d) = ($self->{table}->pk()->[0], $self->root_id_col, $self->father_id_col, $self->depth_col); + + my $new_father = $input->{data}->{$f}; + my ($table, $tree) = ($self->{table}, $self->{tree}); + my %ids = $self->{table}->select($pk, $d => $where)->fetchall_list; + if ($new_father and exists $ids{$new_father}) { + # Cannot update a row to be a child of itself + return $self->error(TREEFATHER => 'WARN'); + } + # keys %ids are the ID's of the records being moved. The values are the depth BEFORE moving. + my $old_parents = $self->parent_ids(id => [keys %ids]); + my $children = $self->child_ids(id => [keys %ids], include_dist => 1); + + my $delete_cond; + for my $parent (keys %ids) { + my @p = @{$old_parents->{$parent}}; + my @c = keys %{$children->{$parent}}; + for (@c) { + if ($_ == $new_father) { + # We can't update a row to be a child of it's children + return $self->error(TREEFATHER => 'WARN'); + } + } + + next unless @p; # If there aren't any old parents, this record already is a root and isn't changing. + + $delete_cond ||= GT::SQL::Condition->new('OR'); + + $delete_cond->add( + GT::SQL::Condition->new( + tree_anc_id_fk => IN => \@p, + tree_id_fk => IN => [$parent, keys %{$children->{$parent}}] + ) + ); + } + + my ($new_depth, $new_root_id, $update, @insert) = (0, 0); + if ($new_father) { + my %new_parents = ($new_father => 0, %{$self->parent_ids(id => $new_father, include_dist => 1)}); + my %insert_seen; + for my $new (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + for my $new_child ($new, keys %{$children->{$new}}) { + next if $insert_seen{$new_child}++; # If it's already seen, it means it's already been handled. This can occur when moving both a child and parent to be children of a new node - the child will be a sibling of its old parent + for my $new_anc (keys %new_parents) { + my $child_dist = $new_child == $new ? 0 : $children->{$new}->{$new_child}; + push @insert, [$new_anc, $new_child, $new_parents{$new_anc} + 1 + $child_dist] unless $insert_seen{"$new_anc\0$new_child"}++; + } + } + } + + ($new_depth, $new_root_id) = $self->{table}->select($d, $r => { $pk => $new_father })->fetchrow; + $new_root_id ||= $new_father; + $new_depth++; + + my %seen; + push @$update, { set => { $r => $new_root_id }, where => { $pk => [grep !$seen{$_}++, keys %ids, map { keys %{$children->{$_}} } keys %$children] } }; + } + else { + $update_hash->{$r} = 0; + my %seen; + for (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + push @$update, { set => { $r => $_ }, where => { $pk => [grep !$seen{$_}++, keys %{$children->{$_}}] } }; + } + } + + my ($delta, %updates, %seen); + for my $parent (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + $delta = $new_depth - $ids{$parent}; + next if !$delta or $seen{$parent}++; + push @{$updates{$delta}}, $parent; + for (keys %{$children->{$parent}}) { + unless ($seen{$_}++) { + $self->debug("Adjusting depth of $_ by $delta") if $self->{_debug}; + push @{$updates{$delta}}, $_; + } + } + } + + for my $delta (keys %updates) { + push @$update, { set => { $d => \"$d + $delta" }, where => { $pk => $updates{$delta} } }; + } + + return { delete => $delete_cond, insert_multiple => [[qw/tree_anc_id_fk tree_id_fk tree_dist/], @insert], update => $update }; +} +END_OF_SUB + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# --------------------------------------------------------- +# This basically executes whatever is decided above. pre_update +# is where everything important is decided. + my $self = shift; + my $input = shift; # This should be whatever pre_update returned. + if ($input->{delete}) { + $self->debug("Deleting now-invalid tree records") if $self->{_debug} >= 1; + $self->{tree}->delete($input->{delete}); + } + if ($input->{insert_multiple} and @{$input->{insert_multiple}} >= 2) { + $self->debug("Inserting new tree records required") if $self->{_debug} >= 1; + $self->{tree}->insert_multiple(@{$input->{insert_multiple}}); + } + if ($input->{update}) { + $self->debug("Updating tree depths required after an update") if $self->{_debug} >= 1; + for (@{$input->{update}}) { + $self->{table}->update($_->{set}, $_->{where}); + } + } +} +END_OF_SUB + +sub children { +# ----------------------------------------------------------- +# $tree->children(id => [$pkval1, $pkval2, ...], max_depth => $max_depth) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->children(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if defined $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->children()'); + for (@$ids) { + $ids = 0 if not $_; + } + + my $parent = $self->{table}->name(); + my $tree = $self->{tree}->name(); + my $roots_only = $input->{roots_only}; + $roots_only = 1 if not $ids; + my ($select_from, $left_join); + if ($roots_only and ref $input->{select_from}) { + $select_from = $input->{select_from}; + $left_join = $input->{left_join}; + } + elsif ($ids and !$roots_only) { + $select_from = $self->{table}->new_relation($parent, $tree); + } + else { + $select_from = $self->{table}; + } + + my $max_depth = $input->{max_depth}; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my $pk = $self->{table}->pk()->[0]; + my $cond; + + my $sort_col = $input->{sort_col} || []; + my $sort_order = $input->{sort_order} || []; + $sort_col = [$sort_col] if $sort_col and not ref $sort_col; + $sort_order = [$sort_order] if $sort_order and not ref $sort_order; + my $sort_col_saved = [@$sort_col]; + my $order_by; + if ($sort_col) { + if (@$sort_order) { + for (0 .. $#$sort_col) { + last if $_ > $#$sort_order; + $sort_col->[$_] .= " $sort_order->[$_]" if $sort_order->[$_]; + } + } + $order_by = "ORDER BY " . join ", ", @$sort_col if @$sort_col; + } + + if ($input->{condition} and UNIVERSAL::isa($input->{condition}, 'GT::SQL::Condition')) { + $cond = new GT::SQL::Condition; + $cond->add($input->{condition}); + } + my %roots_order; # We might need this, if using the roots_order_by option. + if ($ids) { + $cond ||= new GT::SQL::Condition; + if ($roots_only) { + $cond->add("$parent.$root_col" => IN => $ids); + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + else { + $cond->add("$tree.tree_anc_id_fk" => IN => $ids); + $cond->add("$tree.tree_dist" => '<=' => $max_depth) if $max_depth; + } + } + else { + if ($roots_only and $input->{limit}) { + # The following only applies when a limit is being used - otherwise, everything will be returned. + my $c = new GT::SQL::Condition; + $c->add($cond) if $cond; + $c->add($root_col => '=' => 0); + + if ($input->{roots_order_by}) { + $self->{table}->select_options('ORDER BY ' . $input->{roots_order_by}); + } + else { + $self->{table}->select_options($order_by); + } + $self->{table}->select_options("LIMIT $input->{limit}"); + + my @roots = $self->{table}->select($pk => $c)->fetchall_list; + if ($input->{roots_order_by}) { + my $r; + %roots_order = map { ($_ => $r++) } @roots; + } + my @children = $self->{table}->select($pk => { $root_col => \@roots })->fetchall_list; + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$pk" => IN => [@roots, @children]); + } + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + + my $get_cols = $input->{cols}; + $get_cols = [$get_cols] if $get_cols and not ref $get_cols; + if ($get_cols) { + my ($found_root, $found_father, $found_depth, $found_anc); + for (@$get_cols) { + last if $found_root and $found_father and $found_depth; + $found_anc++ if not $found_anc and $_ eq 'tree_anc_id_fk'; + $found_root++ if not $found_root and $_ eq $root_col; + $found_depth++ if not $found_depth and $_ eq $depth_col; + $found_father++ if not $found_father and $_ eq $father_col; + } + push @$get_cols, $root_col if not $found_root; + push @$get_cols, $depth_col if not $found_depth; + push @$get_cols, $father_col if not $found_father; + push @$get_cols, 'tree_anc_id_fk' unless $found_anc or $roots_only; + } + + $select_from->select_options($order_by) if $order_by; + my $sth = $select_from->select($left_join ? ('left_join') : (), $get_cols || (), $cond || ()); + + my $return = $self->_sort($sth, !$ids, $roots_only, (keys %roots_order ? \%roots_order : ())); + + if ($ids) { + for (@$ids) { + $return->{$_} ||= []; + } + } + return $ref ? $return : $return->{$ids ? $ids->[0] : 0}; +} + +sub _sort { +# ----------------------------------------------------------- +# Used internally. Sorts an array ref of hash refs into the +# proper order for a tree. + my ($self, $sth, $from_root, $roots_only, $rp) = @_; + my $pk = $self->{table}->pk()->[0]; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my (@recs, %children, %root_pos, $r); +# When we're done this first part, @recs and %children will look like: +# +# @recs = ( +# [$thread1_immediate_child1, $thread1_immediate_child2, ...], +# [$thread2_immediate_child1, $thread2_immediate_child2, ...], +# ... +# ); +# %children = ( +# $ancestor_id => { +# $child_level_1_rec_1_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# $child_level_1_rec_2_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# ... +# }, +# $ancestor_id => { ... }, +# ... +# ) +# +# Each element in @recs contains the immediate children of a requested base row +# (often a root, but not necessarily). Root positions are stored in %root_pos, +# so that all appropriate rows of a tree are grouped together. +# +# The $ancestor_id in %children is the requested ID. If requesting just roots, +# this is the root ID, otherwise it is the ancestor ID. +# +# To determine the final list, each element will have its children placed +# immediately after itself in a recursive-like way, though not implemented here +# with recursion. +# +# Also note that duplicates are possible, when a requested "root" is really a +# child/descendant of another requested root. + +# $anc_col is how a thread relates; typically this is the root_id, but isn't +# required to be when not using roots_only. + my $anc_col = $roots_only ? $root_col : 'tree_anc_id_fk'; + + while (my $rec = $sth->fetchrow_hashref) { + if (not exists $root_pos{$rec->{$anc_col} || $rec->{$pk}}) { # We haven't encountered this root yet. + $root_pos{$rec->{$anc_col} || $rec->{$pk}} = $from_root ? 0 : $r++; + } + if ($roots_only) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec + if $rec->{$anc_col}; + + push @{$recs[$root_pos{$rec->{$anc_col} || $rec->{$pk}}]}, $rec + if $rec->{$depth_col} == ($from_root ? 0 : 1); + } + else { + if ($rec->{tree_dist} > 1) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec; + } + else { + push @{$recs[$root_pos{$rec->{$anc_col}}]}, $rec; + } + } + } + + my @sorted; +# The goal here is to make @sorted look like this: +# @sorted = ( +# [$reply1, $reply2, ...], +# [$reply1, $reply2, ...], +# ... +# ); +# Each array ref corresponds to one tree. Note that $reply1 could be a root, not a reply :) + +# The mess below properly sorts out a thread, paying attention to both the +# parent and, if specified, sort_col and sort_order. + + # Go through all threads in @recs - each element is a thread + for my $thread (@recs) { + while (@$thread) { + my $this = shift @$thread; + if (my $children = $children{$this->{$anc_col} || $this->{$pk}}->{$this->{$pk}}) { + unshift @$thread, @$children; + } + my $sort_i = $root_pos{$this->{$anc_col} || $this->{$pk}}; + push @{$sorted[$sort_i]}, $this; + } + } + + if ($from_root and $rp) { # If $rp was passed in, order the array refs according to $rp->{$root_id} +# $sort[0] is sorted for all the elements. What we have to do now is group them into threads. + my $i; + my %cur_pos = map { ("$_" => $i++) } @{$sorted[0]}; + $sorted[0] = [ + sort { + ( # This bit sorts by root ID + $rp->{$a->{$anc_col} || $a->{$pk}} + <=> + $rp->{$b->{$anc_col} || $b->{$pk}} + ) + || + ($cur_pos{$a} <=> $cur_pos{$b}) # Keep the order for elements with the same root id + } + @{$sorted[0]} + ]; + } + + my $return = {}; + for my $tree (@sorted) { + my $root = $from_root ? 0 : $tree->[0]->{$anc_col}; + push @{$return->{$root}}, @$tree; + } + + $return; +} + +$COMPILE{parents} = __LINE__ . <<'END_OF_SUB'; +sub parents { +# ----------------------------------------------------------- +# $tree->parents(id => [$pkval1, $pkval2, ...]) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parents(HASH or HASH_REF)'); + + $self->{tree} and $self->{table} or return $self->error(NOTREEOBJ => FATAL => '$tree->parents()'); + + my $parent = $self->{table}->name(); + $parent =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $tree = $self->{tree}->name(); + $tree =~ s/^\Q$self->{connect}->{PREFIX}\E//; + + my $rel = $self->{table}->new_relation($parent, $tree); + + my $get = $input->{cols}; + $get = [] unless ref $get eq 'ARRAY'; + my $depth = $self->depth_col; + if (@$get) { # If $get is empty, everything will be returned. + my ($found_t, $found_d); + for (@$get) { + $found_t++ if $_ eq 'tree_id_fk'; + $found_d++ if $_ eq $depth; + last if $found_t and $found_d; + } + push @$get, 'tree_id_fk' if not $found_t; + push @$get, $depth if not $found_d; + } + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not $ref; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parents()'); + + $GT::SQL::Tree::Relation::Anc_Join = 1; + my $sth = $rel->select(@$get => { tree_id_fk => $ids }); + $GT::SQL::Tree::Relation::Anc_Join = 0; + + my $return = { map { ($_ => []) } @$ids }; + + while (my $rec = $sth->fetchrow_hashref) { + push @{$return->{$rec->{tree_id_fk}}}, $rec; + } + + for (@$ids) { + @{$return->{$_}} = sort { $a->{$depth} <=> $b->{$depth} } @{$return->{$_}}; + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{child_ids} = __LINE__ . <<'END_OF_SUB'; +sub child_ids { +# ----------------------------------------------------------- +# $tree->child_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing at least an 'id' key. +# The value of the 'id' key is an array reference of ancestor ID's whose +# descendants (children, children's children, etc.) you are looking for. +# max_depth can be specified to limit a maximum child depth to return. +# OUT: Depends on include_dist. +# Without include_dist: hash ref of array ref. There will be one key for +# each ID you pass in. If there are no children, the array ref value will +# contain no elements. Each array element is a child ID. +# With include_dist: hash ref of hash refs. One key for each ID you pass +# in. The inner hash refs have keys of the ID's and values of the +# distance between what you passed in and the element. Essentially, +# keys() of an include_dist hash is the same as the array ref without +# include depth. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->child_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->child_ids()'); + + my @get = qw/tree_anc_id_fk tree_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_anc_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($anc, $id, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$anc}->{$id} = $dist; + } + else { + push @{$return->{$anc}}, $id; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{parent_ids} = __LINE__ . <<'END_OF_SUB'; +sub parent_ids { +# ----------------------------------------------------------- +# $tree->parent_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing an 'id' key. +# The value of the 'id' key is an array reference of children ID's whose +# ancestors (parents, parents' parents, etc.) you are looking for. +# OUT: hash ref of array refs. There will be one key for each ID you pass in. +# Each array ref contains the ID's of the parents. +# Liks child_ids, the return is different if you pass in "include_dist". +# See child_ids for a description. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parent_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parent_ids()'); + + my @get = qw/tree_id_fk tree_anc_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($id, $anc, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$id}->{$anc} = $dist; + } + else { + push @{$return->{$id}}, $anc; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{num_children} = __LINE__ . <<'END_OF_SUB'; +sub num_children { +# ----------------------------------------------------------------------------- +# $tree->num_children([$pkval1, $pkval2, ...]) +# IN : A list or array reference of of parents ID's whose child counts +# you are looking for. +# OUT: Hash reference of ID => NUM_CHILDREN pairs. Note that this is the +# number of children (i.e. depth = 1), not descendants. +# + my $self = shift; + + my @ids = map { + ref eq 'ARRAY' + ? @$_ + : ref() + ? $self->error(BADARGS => FATAL => '$tree->num_children(ARRAY or ARRAYREF)') + : $_ + } @_; + + @ids or return $self->error(TREENOIDS => FATAL => '$tree->num_children()'); + + $self->{tree}->select_options('GROUP BY tree_anc_id_fk'); + my %return = $self->{tree}->select(tree_anc_id_fk => 'COUNT(*)', { tree_anc_id_fk => \@ids, tree_dist => 1 })->fetchall_list; + + for (@ids) { $return{$_} ||= 0 } + + return \%return; +} +END_OF_SUB + + +package GT::SQL::Tree::Relation; +# This is here to subclass the table->tree relation so that selects work properly + +use GT::SQL::Relation; +use vars qw/@ISA $ERROR_MESSAGE $Anc_Join/; # $Anc_Join is set by the tree module when the join should be on tree_anc_id_fk rather than tree_id_fk +@ISA = $ERROR_MESSAGE = 'GT::SQL::Relation'; + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + if (@$relations != 2) { + return $self->error(TREEBADJOIN => FATAL => "@$relations"); + } + my ($table, $tree) = @$relations; + ($table, $tree) = ($tree, $table) if !$relations->[0]->{schema}->{tree}; + + return "$tree->{name}." . ($Anc_Join ? 'tree_anc_id_fk' : 'tree_id_fk') . " = $table->{name}." . $table->pk()->[0]; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree - Helps create and manage a tree in an SQL database. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + + my $tree = $table->tree; + my $children = $tree->children(id => [1,2,3], max_depth => 2); + + my $parents = $tree->parents(id => [4,5,6]); + +=head1 DESCRIPTION + +GT::SQL::Tree is designed to implement a tree structure with a SQL table. Most +of the work on managing the table is performed automatically behind the scenes, +however there are a couple of front end methods to retrieving the tree nodes +from a GT::SQL::Tree object. + +=head1 METHODS + +=head2 new, tree + +Typically, the way to get a tree object is to call ->tree on a table object. The +table object then calls GT::SQL::Tree->new for you and returns the results, +which is a GT::SQL::Tree object. Typically you should not call ->new directly, +but instead let $table->tree call it with the proper arguments. + +=head2 create, add_tree + +To use GT::SQL::Tree, you need to first call create(). You shouldn't call it +directly, but instead call ->add_tree() on an editor object. The arguments to +add_tree are passed through to create, so that they are essentially the same +(there is one exception - add_tree passed in C $table_object>). + +create() will create a tree table, with the name passed on the name of the table +passed in. For example, if you wish to build a tree on 'MyTable', the tree table +that is created by create() will be named MyTable_tree. The tree table provides +easy one-query access to all of a nodes parents or children, and also keeps +track of the number of hops between a node and its descendant, allowing you to +limit how far you descend into the tree. + +The following arguments are required: + +=over 4 + +=item table + +This contains the table object for the table the tree is to be built upon. Note +that when calling add_tree you B specify this - add_tree passes it +along on its own. + +=item father + +This must specify the name of the father ID column. The father ID column +controls the relationship between father/child. + +For example, if your primary key is "my_id" and your father id column is +"my_father_id", you would pass in "my_father_id" as the value to C. + +=item root + +This is used to specify the name of the root column. For example, if your +primary key is "my_id" and your root id column is "my_root_id", you would pass +in "my_root_id" as the value to C. + +=item depth + +This is used to specify the name of the depth column for the table. For example, +if you are using a column named "my_depth" to keep track of the depth of a node, +you would pass in "my_depth" as the value to C. + +=back + +The following are optional arguments to create/add_tree: + +=over 4 + +=item force + +Takes a value such as 'force' or 'check'. This value is passed on to the +GT::SQL table creation subroutine. + +=item rebuild + +You can pass in a GT::SQL::Tree::Rebuild object if you have an incomplete or +invalid table structure. See L for more details. + +=item debug + +Sets the debug level of the tree object. add_tree() automatically passes in the +debug value for the table object, so it normally is not necessary to set this. + +=back + +=head2 destroy, drop_tree + +You can call C<$tree-Edestroy> to destroy a tree. This involves dropping the +tree table and deleting the tree reference from the table the tree was on. This +can be called by calling C<$tree-Edestroy()> on a GT::SQL::Tree object, +however this is typically invoked by calling C<$editor-Edrop_tree()> on a +table editor object. + +Neither C<$tree-Edestroy()> nor C<$editor-Edrop_tree()> take any +arguments. + +=head2 root_id_col, father_id_co, depth_col + +These three tree object methods return the name of the associated column in the +main table. Usually you will already know them, and these methods are primarily +used internally. + +=head2 children + +This is where the usefulness of the tree module comes into play. +C<$tree-Echildren> is used to access all of the children of a particular +node. It takes a wide variety of arguments to control the return. + +Usually, the return will be either a hash reference of array references each +containing hash references, or else an array reference of hash references. Which +reference you get depends on what you request via the C parameter, described +below. Each inner hash reference is a row from the database, typically a joined +row from the table the tree is on with the tree table, however the +C, C, and C parameters all change this behaviour. + +The arguments to C are as follows: + +=over 4 + +=item id + +The value of the id key is either a scalar value, or an array reference. The +value/values to id should be the id whose descendants you are looking for. For +example, if you are looking for the children of ID 3 and ID 4, you would pass in +C [3, 4]>. The return value of children will be a hash reference +containing two keys: 3 and 4. + +If you are looking for the children of a single ID and pass the id as a scalar +value, you will get back an array reference as described above. + +So, basically, if the value to id is an array reference, you will get back a +hash reference of array references of hash references; if it is a scalar value, +you will get back an array reference of hash references. + $tree->children(id => [1])->{1}; +and + $tree->children(id => 1); +will result in the same thing. + +To get all the trees in a single query, you pass in 0 as the value. This is as +if you are requesting the children of the imaginary root to which all roots +belong. + +C is the only required parameter. + +=item max_depth + +You can specify a max_depth value to specify that the records returned should +not be more a certain distance from the node. For example, supposing you have +this tree: + a + b + c + d +Selecting the children of a with a max_depth of 1 would return just b, not c or +d. A max_depth of 2 would return b and c. + +Not specifying max_depth means that you do not want to limit the maximum +distance from the parent of the returned values. + +=item cols + +You can specify an array reference as the value to C to alter the values +returned. Instead of doing "SELECT * FROM ...", the query will be "SELECT FROM ...". Note, however, that the father, root, and depth columns +are required and will be present in the rows returned whether or not you specify +them. + +=item sort_col, sort_order + +Where the C option sorts the results based on tree levels, C and +C control the sorting for nodes with the same father ID. For +example, with this tree: + a + b + c +C and C affect whether or not b comes before or after c. +The value of each can either be a scalar value or an array reference. There is +essentially no difference, the scalar value is just a little easier when you are +only sorting on a single column. The values of C should be column +names, and the values of C 'ASC' or 'DESC', per sort column +respectively. For example: + sort_col => ['a','b'], sort_order => ['ASC', 'DESC'] +will sort first in ascending order based on the value of a, then descending +order based on the value of column b. This correlates directly to SQL - it +becomes "ORDER BY a ASC, b DESC". + +You can specify a different sort order for roots by using the C +option, when using C 0>. See below. + +=item condition + +If you want to limit the results, you can pass a GT::SQL::Condition object into +C via the condition key. The condition will apply to the select +performed. For example, if you want to select rows with a column "a" having a +value less than 20, you could do: + my $cond = GT::SQL::Condition->new(a => '<' => 20) + my $children = $tree->children(..., condition => $cond); + +=item limit + +Like condition, you can specify any valid LIMIT _____ value here, for example +"50, 25". This option is only used when using C 0> - it will limit the +number of roots returned, taking into account the sort_col and sort_order. + +=item roots_only + +If you specify this option, it will assume that what you passed in via C +consists only of root_ids. Doing so makes a join with the tree table +unneccessary and allows you to use the C option. This option can be +used (and generally this is a good idea) when specifying C 0>. + +=item roots_order_by + +This option controlls the order of root posts, when selecting roots using +C 0> and a limit. C above will affect the order of +children of the roots, but the order of the roots themselves will be controlled +by whatever C value you specify here. + +Again, this option requires that C 0>, C, and C are +also being used. + +If this option is omitted, the C will be generated from the values of +the C and C options. + +=item select_from + +If you are using roots_only, you can also specify the C option. +This option allows you to perform the selects from a GT::SQL::Relation object +instead of just the table associated with the tree. Note that the table +associated with the tree must be part of the relation, however you can have as +many other tables as you like. + +=item left_join + +If the select_from relation should be a left join, pass C 1>. +This simply passes the C option to ->select. This option is only +applicable when select_from is used. + +=back + +=head2 parents + +This is effectively the opposite of children. Instead of getting back all of the +children nodes, it gives the parents, all the way up to the root for any given +node. The return value is the same as that of C, so see that section. + +Each array returned by C is sorted by depth from root to parent. + +=over 4 + +=item id + +C is the only required parameter for C. It should be either a +scalar value or an array reference. You specify the ID's of children whose +parents you are looking for. The type of argument (scalar or array ref) affects +the return in the same way as C. + +=item cols + +C works in a similar way to the C parameter to C. You +specify the columns you want in the return as an array ref. What you get back +will have these columns in it. If C is not specified, you'll get back all +columns. + +Note that 'tree_id_fk' and the depth column for the table are required fields +and will be added if not specified. + +=back + +=head2 child_ids + +If you are looking for just the ID's of the children of a particular node, you +should use this. The return value is one of the following, depending on what you +pass in: + +hash reference of array references: + { ID => [ID, ID, ...], ... } +with one ID in the hash reference for each id you specify. The array reference +contains the child ID's of the key ID. + +hash reference of hash references: + { ID => { ID => dist, ID => dist, ... }, ... } +with one ID in the other hash reference for each id you specify. The inner hash +reference is made of child_id => child_distance key-value pairs. + +array reference or hash reference: + [ID, ID, ...] +hash reference: + { ID => dist, ID => dist } + +The first two apply when passing in an array reference for C, the latter two +when passing a scalar value for C. The first and third are without +C specified, the second and fourth occur when you specify +C. + +=over 4 + +=item id + +Like all other accessors, child_ids takes a scalar value or array reference as +the C value. Return as noted above. + +=item include_dist + +This changes the return as noted above - instead of just getting an array +reference of child ID's, you get the child ID's as the keys of a hash reference, +and the distances of the child from the parent you requested as the values. + +=back + +=head2 parent_ids + +Exactly the same as child_ids, except that this works I the tree instead of +I. Takes the same arguments, gives the same possible returns. + +=head1 INDICES + +A tree requires a few indices to get optimal performance out of it. If the table +is never expected to be more than just a few rows, you won't notice a +substantial difference, however, as with any table, as the table grows the +performance proper indexing provides becomes more appreciable. + +Two indices are created automatically on the tree table, one on tree_id_fk, and +the other on tree_anc_id_fk,tree_dist, so you don't need to worry about that +table. + +Obviously, the usage of the tree affects how many indices you want, this section +is simply to provide some general guidelines for the indices required. + +Because the roots_only option is based solely on the main table and not the +tree, if you are using roots_only (calling children with id => 0 automatically +turns on the roots_only option), you want to make sure you have an index on the +root column. If you also use the max_depth depth option, add the depth column to +this index. + +Keep in mind that you may need to mix other columns in here if you are using a +condition with children(). This also applies when using the C and +C parameters - basically you need to figure out what your indices +are, and then add in the root column and, if using max_depth, the depth column. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Tree.pm,v 1.29 2005/05/31 06:26:32 brewt Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Tree/Rebuild.pm b/site/glist/lib/GT/SQL/Tree/Rebuild.pm new file mode 100644 index 0000000..c471ea1 --- /dev/null +++ b/site/glist/lib/GT/SQL/Tree/Rebuild.pm @@ -0,0 +1,237 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : +# $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# This goes hand in hand with GT::SQL::Tree and is very useful in +# turning an existing table without the root, and/or depth columns +# into a GT::SQL::Tree-compatible format. +# +package GT::SQL::Tree::Rebuild; +# =============================================================== +use strict; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +# New returns a GT::SQL::Tree::Rebuild object when you can pass to GT::SQL::Tree. +# When you are adding a tree to an existing table, but the table does not have +# the root and/or depth columns, you get a Rebuild object, then pass it to +# ->add_tree so that your tree can be built anyway. +# You need to call new with the following options: +# table => $Table_object +# missing_root => sub { ... }, # Only if you are missing the root. The code reference should return the pk of the root. +# missing_depth => 1, # Only if you are missing the depth. The code reference should return the depth of the node. +# missing_father => 1, # Only if you are missing the father. The code reference should return the pk of the father. +# cols => [...], # The columns you want %row (discussed below) to contain +# +# The code references are passed two arguments: +# \%row, # A row from the table. If using the cols option, it will only have those columns. +# $table_object, # This is the same object you pass to new() +# \%all # This is a hash reference of all rows; each key is a primary key, each value the row. This may or may not be of use to you. +# +# For depth, %all will have root and father ids set, for roots father ID's will be set. +# +# NOTE: The father, root, and depth columns must exist beforehand. +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new(HASH or HASH REF)'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ ... table => $table_obj ... })'); + for (qw(missing_root missing_depth missing_father)) { + next unless exists $opts->{$_}; + $self->{$_} = $opts->{$_}; + ref $self->{$_} eq 'CODE' or return $self->error(BADARGS => FATAL => '$obj->new({ ... ' . $_ . ' => sub { ... } ... })'); + } + $self->{cols} = $opts->{cols} if $opts->{cols}; + $self->{cols} = [$self->{cols}] if $self->{cols} and not ref $self->{cols}; + $self->{cols} ||= []; + $self->{order_by} = $opts->{order_by} if $opts->{order_by}; + + $self->{missing_root} or $self->{missing_depth} or $self->{missing_father} or return $self->error(BADARGS => FATAL => 'At least one of "missing_root", "missing_depth", or "missing_father" must be passed to $obj->new({ ... })'); + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + $self; +} + +# Called internally by the GT::SQL::Tree object. This does all the calculations. +# Note that this only rebuilds the table itself, GT::SQL::Tree->create will still +# have to create its tree table. +sub _rebuild { + my ($self, $pk, $root_col, $father_col, $depth_col) = @_; + my $table = $self->{table}; + + my $count = $table->count(); + for (my $i = 0; $i < $count; $i += 10000) { + $table->select_options("ORDER BY $self->{order_by}") if exists $self->{order_by}; + $table->select_options("LIMIT 10000" . ($i ? " OFFSET $i" : "")); + my $sth = $table->select(@{$self->{cols}}); + while (my $row = $sth->fetchrow_hashref) { + my %update; + if ($self->{missing_father}) { + my $father_id = $self->{missing_father}->($row, $table); + $update{$father_col} = $father_id unless $row->{$father_col} == $father_id; + $row->{$father_col} = $father_id; + } + if ($self->{missing_root}) { + my $root_id = $self->{missing_root}->($row, $table); + $update{$root_col} = $root_id unless $row->{$root_col} == $root_id; + $row->{$root_col} = $root_id; + } + if ($self->{missing_depth}) { + my $depth = $self->{missing_depth}->($row, $table); + $update{$depth_col} = $depth unless $row->{$depth_col} == $depth; + $row->{$depth_col} = $depth; + } + + $table->update(\%update, { $pk => $row->{$pk} }) if keys %update; # If the new value(s) is/are 0, like the default value(s), %update will be empty + } + } + + return 1; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + use GT::SQL::Tree::Rebuild; + + my $rebuild = GT::SQL::Tree::Rebuild->new( + table => $DB->table('MyTable'), + missing_root => \&root_code, + missing_father => \&father_code, + missing_depth => \&depth_code, + order_by => 'column_name' + ); + + $DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild); + +=head1 DESCRIPTION + +GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and +aids in turning an existing table into one with the neccessary root, father and +depth columns needed by GT::SQL::Tree. + +The main purpose is to do a one-shot conversion of a table to make it compatible +with GT::SQL::Tree. + +=head2 new - Create a Rebuild object + +There is only one method that is called - new. You pass the arguments needed +and get back a GT::SQL::Tree::Rebuild object. This object should then be passed +into GT::SQL::Tree->create (typically via C<$editor-Eadd_tree()>) + +new() takes a hash with up to 4 argument pairs: "table" (required), and one or +more of "missing_root", "missing_father", or "missing_depth". The values are +explained below. + +=over 4 + +=item table + +Required. You specify the table object for the table to rebuild. For example, if +you are going to add a tree to the "Category" table, you provide the "Category" +table object here. + +=item cols + +By default, an entire row will be returned. To speed up the process and lower +the memory usage, you can use the C option, which specifies the columns to +select for $row. It is recommended that you only select columns that you need as +doing so will definately save time and memory. + +=item missing_father, missing_root, missing_depth + +Each of these arguments takes a code reference as its value. The arguments to +the code references are as follows: + +=over 4 + +=item $row + +The first argument is a hash reference of the row being examined. Your job, in +the code reference, is to examine $row and determine the missing value, +depending on which code reference is being called. missing_root needs to return +the root_id for this row; missing_father needs to return the father_id, and the +missing_depth code reference should return the depth for the row. + +=item $table + +The second argument passed to the code references is the same table object that +you pass into new(), which you can select from if neccessary. + +=back + +=item missing_father + +The C code reference is called first - before C +and C. The code reference is called as described above and should +return the ID of the father of the row passed in. A false return (0 or undef) is +interpreted as meaning that this is a root and therefore has no father. + +=item missing_root + +C has to return the root of the row passed in. This is called +after C, so the $row will contain whatever you returned in +C in the father ID column. Of course, this only applies if using +both C and C. + +=item missing_depth + +C has to return the depth of the row passed in. This is called +last, so if you are also using C and/or C, you +will have whatever was returned by those code refs available in the $row. + +=item order_by + +The query done to retrieve records can be sorted using the C option. +It should be anything valid for "ORDER BY _____". Often it can be useful to have +your results returned in a certain order - for example: + order_by => 'depth_column ASC' +would insure that parents come before roots. Of course, this example wouldn't +work if you are using "missing_depth" since none of the depth values will be +set. + +=back + +Once you have a GT::SQL::Tree::Rebuild object, you should pass it into +Ccreate> (which typically involves passing it into +C<$editor-Eadd_tree()>, which passed it through). Before calculating the +tree, GT::SQL::Tree will call on the rebuild object to reproduce the father, +root, and/or depth columns (whichever you specified). + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/SQL/Types.pm b/site/glist/lib/GT/SQL/Types.pm new file mode 100644 index 0000000..31441de --- /dev/null +++ b/site/glist/lib/GT/SQL/Types.pm @@ -0,0 +1,385 @@ +1; + +__END__ + +=head1 NAME + +GT::SQL::Driver::Types - Column types supported by GT::SQL + +=head1 SYNOPSIS + + my $c = $DB->creator('new_table'); + $c->cols({ + column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 } + # ... more columns ... + }); + + my $e = $DB->editor('table_name'); + $e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' }); + +=head1 DESCRIPTION + +This module should not be used directly, however the documentation here +describes the different types support by GT::SQL and any caveats associated +with those types. + +=head1 ATTRIBUTES + +All types are specified as a C { column definition }> pair, +where the column definition should contain at least a C key containing +one of the L outlined below. Commonly accepted attributes are: + +=over 4 + +=item not_null + +Used to specify that a column should not be allowed to contain NULL values. +Note that for character/string data types, a 0-character string (and, for +C/C columns, strings containing only spaces), B considered +NULL values are are not permitted if the column is specified as C. +The value passed to not_null should be true. + +=item default + +Used to specify a default value to be used for the column when no explicit +value is provided when a row is inserted. The default value is also used for +the value in existing rows when adding a not_null column to an existing table - +in such a case, the C is B. + +Also see the L|/TEXT> section regarding caveats and limitations of +using C's for C types. + +=back + +Other column attributes are supported as outlined below. In addition to +attributes mentioned in this document, various attributes are available that +influence automatically-generated forms displayed by GT::SQL::Admin - see +L for details on these attributes. + +=head1 TYPES + +=head2 Integer types + +=over 4 + +=item TINYINT + +The C type specifies an 8-bit integer able to handle values from -128 +to 127. Some databases will allow larger values due to not supporting an +appropriate data type. The C column attribute I turn this into +an unsigned value supporting values from 0 to 255; due to this type being +implemented as a larger integer type in some databases (which, incidentally, +coincide with the databases not supporting an unsigned 8-bit C) using +an C TINYINT type will result in a column able to store any value +from 0-255, unlike most of the larger integer types below. + +=item SMALLINT + +The C type specifies a 16-bit integer able to handle values from +-32768 to 32767. The C column attribute I turn this into an +unsigned value supporting values from 0 to 65535, however this is B +guaranteed. If you need to store values in the 32768-65535 range, a larger +type is recommended. + +=item MEDIUMINT + +The C type (only natively supported by MySQL) specifies a 24-bit +integer type able to hold values from -8388608 to 8388607. If the C +column attribute is specified, this allows values from 0 to 16777215. Due to +this being supported with the C attribute, or implemented as a larger +data type, an C C will always supported values up to +16777215. + +=item INT, INTEGER + +The C type specifies a 32-bit integer able to hold values from -2147483648 +to 2147483647. If the C column attribute is specified, the column +I support values from 0 to 4294967295, however this is B guaranteed. +If values larger than 2147483647 are needed, using the C type below is +recommended. C is an alias for C. + +=item BIGINT + +The largest integral type, C specifies a 64-bit integer value able to +hold values from -9223372036854775808 to 9223372036854775807. If specified as +C, the column I support values from 0 to 18446744073709551616, +but this is B guaranteed. If larger values are needed, use the C +type with a C value of C<0>. + +=item back + +=head2 Float-point types + +=over 4 + +=item REAL, FLOAT + +The C type specifies a 32-bit floating-point (i.e. fractional) number, +accurate to 23 binary digits (which works out to I 6 decimal +digits). The values may be signed, and can range from at least as small as +10^-37 to at least as large as 10^37. For more precise values, the C +type is recommended. For exact precision (i.e. for monetary values), the +(often slower) C type is recommended. C is an alias for +C. + +=item DOUBLE + +The C type specifies a 64-bit floating-point (i.e. fractional) number, +accurate to 52 binary digits (I 15 decimal digits). The values +may be signed, and can range from at least as small as 10^-307 to at least as +large as 10^308 (except under Oracle - see below). For exact precision (i.e. +for monetary values), the (often slower) C type is recommended. + +Take note that Oracle doesn't properly support the full range supported by +other databases' C types - the smallest number supported (assuming +precision to digits) is 10^-113 - specifically, the number of digits after the +decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while +1.23456789012e-117 is not. The larger number Oracle supports is just less than +1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you +need to store numbers larger or smaller than this amount, you'll have to find +some other way to store your numbers (i.e. Math::BigFloat with a C). + +=back + +=head2 Aribtrary precision numbers + +=over 4 + +=item DECIMAL + +The C type is provided to support numbers of arbitrary precision. It +requires two attributes, C and C, where C specifies +the number of decimal places, and precision specifies the number of overall +digits. For example, C<123.45> has a C of 5, and a C of 2. +C<42> has a C or 2, and a C of 0. C must be less than +C, and C must not exceed 38. Also, although the value +stored and retrieved is completely accurate within it's given precision and +scale range, the accuracy available for comparisons (i.e. column = number) is +only reliably accurate to approximately the same level as DOUBLE's - that is, +about 15 digits. + + +=back + +=head2 Character types + +=over 4 + +=item CHAR + +The C type is used to specify a string of characters from 1 to 255 +characters long. It takes a C attribute which must be 255 or less, and +specifies the size of the column values - if not specified, 255 will be used. +This implementation's C type, for historic reasons, B pad +inserted values with spaces, but B trim trailing spaces when retrieving +and/or comparing values. Note that this is B SQL compliant C +behaviour - SQL-compliant C's are padded with spaces up to their size. + +What this ends up meaning is that for everything except MySQL, C columns +will be mapped to C columns. Note that even MySQL, which is the only +database for which C's are not automatically mapped into C's, +will I convert C columns to C columns if any +non-fixed-size datatype (anything other than a C or numeric types) is +used in or added to the table. As a general rule, C is preferred over +C except when dealing with columns whose values don't vary significantly +in length B are in a table that only contains fixed-size data types +(C's and numeric types). Everywhere else, use C's, since that's +what you'll be getting anyway. + +A C attribute is supported, which I indicates that comparisons +with this field should be case-sensitive. Note that this only works on +databases that actually have a case-sensitive C field - currently, only +MySQL. + +=item VARCHAR + +The C type is identical to the above C type B as +follows. Unlike a C, a C column does not take up C bytes +of storage space - typically the storage space is only slightly larger +(typically 1 byte) than the size of the value stored. As such, C's +are almost always preferred over columns, except for nearly-constant sized +data, or tables with all fixed-width data types (C's, C's, and +non-C numeric types). C columns will not be padded with +whitespace up to C, however trailing whitespace C be trimmed from +values. + +As with C, the C attribute I make the C values +case-sensitive for the matching purposes. + +=item TEXT + +The C type is similar to C types, except that they are always +case-insensitive for matching/equality, and can contain longer values. The +C type takes a C attribute which contains the length required - if +not provided, a value of approximately 2 billion is used. Note that the +maximum size of the column will usually be larger than the value you specify to +C - it simply indicates to the driver to use a field capable of at least +the size specified. The values of C fields are case-insensitive in terms +of matches and equality. The maximum C value, and the default, is +approximately 2 billion. + +Certain aliases are provided with implicit size defaults - C, +C, C, and C, which are equivelant to C +with C values of 255, 65535, 16777215, and 2147483647, respectively. + +Depending on the C value, certain databases _may_ use different +underlying types. MySQL, for example, uses the smallest possible type between +its native C, C, C, and C types. As +such, it is recommended that you use a sufficiently large C value unless +absolutely sure that you will never need a larger value. + +Also note that C types B support normal equality operations - in +fact, the only portable things that can be done with C columns is C tests (in GT::SQL this means "=" C) and C comparisons - but, +for portability with all supported databases, the argument of a C may not +exceed 4000 characters. + +Also note that the C value will be ignored by MySQL, which does not +support having default values on C columns. Everything else, however, +will properly support this, and the default will still be used when inserting +with GT::SQL even when using MySQL. Also note that the default value of +C types B exceed 3998 characters, due to limits imposed by some +databases. Longer indexes may work in some cases, but are not guaranteed - for +example, a table resync on MSSQL will not work. + +=item ENUM + +The C type is a MySQL-only type that supports certain fixed string +values. On non-MySQL databases, it is simply mapped to a C column. +It requires a C option which should have a value of an array reference +of string values that the ENUM should permit. The C type is generally +discouraged in favour of a C, C, or an +L column, all of which provide more flexibility +(i.e. if you want to add a new possible value) and are not a single +database-specific type. + +=back + +=head2 Date/time types + +All of the date/time types support by MySQL will be handled by GT::SQL, for +compatibility reasons. However, all types other than DATE and C +should be considered deprecated as cross-database compatibility is not possible +using these types. In particular, C will work exactly like a +C on every non-MySQL database; C
        ~; + for my $key (sort keys %$tags) { + my $val = $tags->{$key}; + $val = $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val = $dumper->dump(data => $val) if ref $val; + $val = GT::CGI::html_escape($val); + local $^W; + $val =~ s/ / /g; + $val =~ s|\n|
        \n|g; + $output .= qq~~; + } + $output .= qq~
        <$font>Available Variables
        <$font>$key$val
        ~; + } + return \$output; +} +END_OF_SUB + +sub _parse { +# --------------------------------------------------------------- +# Sets the parsing options, and gets the code ref and runs it. +# + my ($self, $template, $opt) = @_; + + my $compress = exists $opt->{compress} ? $opt->{compress} : $self->{compress}; + local $self->{opt} = {}; + $self->{opt}->{strict} = exists $opt->{strict} ? $opt->{strict} : $self->{strict}; + $self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print}; + $self->{opt}->{escape} = exists $opt->{escape} ? $opt->{escape} : $self->{escape}; + $self->{opt}->{package} = exists $opt->{package} ? $opt->{package} : caller(1) || 'main'; + $self->{opt}->{func_code} = exists $opt->{func_code} ? $opt->{func_code} : $self->{func_code}; + $self->{opt}->{heap} = exists $opt->{heap} ? $opt->{heap} : $self->{heap}; + +# Set the root if this is a full path so includes can be relative to template. + if (substr($template, 0, 1) eq '/' or substr($template, 1, 1) eq ':') { + $self->{root} = substr($template, 0, rindex($template, '/')); + substr($template, 0, rindex($template, '/') + 1) = ''; + } + my $root = $self->{root}; + my $full_file = $self->{root} . '/' . $template; + my ($code, $dont_save) = $self->{opt}->{print} == 2 + ? @{$FILE_CACHE_PRINT{$full_file}}{qw/code dont_save/} + : @{$FILE_CACHE{$full_file}}{qw/code dont_save/}; + + my $output = $code->($self); + return $output if $self->{opt}->{print} == 2; + +# Compress output if requested. + if ($compress) { + $self->debug("Compressing output for template '$template'.") if $self->{_debug}; + + my ($pre_size, $post_size); + $pre_size = length $$output if $self->{_debug}; + $self->_compress($output); + $post_size = length $$output if $self->{_debug}; + + $self->debug(sprintf "Output reduced %.1f%%. Size before/after compression: %d/%d.", 100 * (1 - $post_size / $pre_size), $pre_size, $post_size) if $self->{_debug}; + } + return $$output; +} + +$COMPILE{_compile_template} = __LINE__ . <<'END_OF_SUB'; +sub _compile_template { +# ------------------------------------------------------------------- +# Loads the template parser and compiles the template and saves it +# to disk. +# + my ($self, $file, $full_compiled, $print) = @_; + $self->debug("Compiling template $file (into $full_compiled)") if $self->{_debug}; + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + + my ($code, $files) = $parser->parse( + $file, + { root => $self->{root} }, + ($print and $print == 2) + ); + + local *FH; + my $tmpfile = $full_compiled . "." . time . "." . $$ . "." . int(rand(10000)) . ".tmp"; + open FH, ">$tmpfile" or return $self->fatal(CANTOPEN => $tmpfile, "$!"); + my $localtime = localtime; + my $file_string = '[' . join(',', map { + my ($file, $path, $mtime, $size) = @$_; + for ($file, $path) { s/([\\'])/\\$1/g if defined } + "['$file'," . (defined $path ? "'$path'" : 'undef') . ",$mtime,$size]" + } @$files) . ']'; + + (my $escaped = $full_compiled) =~ s/(\W)/sprintf "_%x", ord($1)/ge; + print FH qq +|# This file is a compiled version of a template that can be run much faster +# than reparsing the file, yet accomplishes the same thing. You should not +# attempt to modify this file as any changes you make would be lost as soon as +# the original template file is modified. +# Editor: vim:syn=perl +# Generated: $localtime +local \$^W; +{ + files => $file_string, + parser_version => $VERSION, + code => \\>::Template::parsed_template +}; +sub GT::Template::parsed_template { +$$code +}|; + close FH; + unless (rename $tmpfile, $full_compiled) { + unlink $tmpfile; + return $self->fatal(RENAME => $tmpfile, $full_compiled, "$!"); + } + chmod 0666, $full_compiled; + return; +} +END_OF_SUB + +$COMPILE{_compile_string} = __LINE__ . <<'END_OF_SUB'; +sub _compile_string { +# ----------------------------------------------------------------------------- +# Like _compile_template, except that this returns a code reference for the +# passed in string. +# Takes two arguments: The string, and print mode. If print mode is on, the +# code will print everything and return 1, otherwise the return will be the +# result of the template string. + my ($self, $string, $print) = @_; + $self->debug("Compiling string '$string' in " . (($print and $print == 2) ? "stream mode" : "return mode")) if $self->{_debug}; + if (!$string) { + $self->debug("Actual parsing skipped for empty or false string '$string'") if $self->{_debug}; + if ($print and $print == 2) { + return sub { print $string }; + } + else { + return sub { \$string }; + } + } + + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + my ($eval) = $parser->parse( + $string, + { + root => $self->{root}, + string => $string + }, + ($print and $print == 2) + ); + + my $code; + local ($@, $^W); + eval { # Catch tainted data + eval "sub GT::Template::parsed_template { $$eval }"; + $code = \>::Template::parsed_template unless $@; + }; + + unless (ref $code eq 'CODE') { + return $self->fatal(CANTRUNSTRING => "sub GT::Template::parsed_template { $$eval }", "$@"); + } + return $code; +} +END_OF_SUB + +$COMPILE{_call_func} = __LINE__ . <<'END_OF_SUB'; +sub _call_func { +# ----------------------------------------------------------------------------- +# Calls a function. The arguments are set in GT::Template::Parser. If the +# function returns a hash, it is added to $self->{VARS}. The result of the +# function is escaped, if escape mode is turned on. +# + my ($self, $torun, @args) = @_; + my $aliased; + if (exists $self->{ALIAS}->{$torun}) { + $torun = $self->{ALIAS}->{$torun}; + $aliased = 1; + } + no strict 'refs'; + my $rindex = rindex($torun, '::'); + my $package; + $package = substr($torun, 0, $rindex) if $rindex != -1; + my ($code, $ret); + my @err = (); + my $ok = 0; + if ($package) { + my $disabled; + if ($aliased) { + if ($self->{disable}->{alias_args} and @args) { + $disabled = $ERRORS->{DISABLED_ALIASARGS}; + } + } + elsif ($self->{disable}->{functions}) { + $disabled = $ERRORS->{DISABLED_FUNC}; + } + elsif ($self->{disable}->{function_args} and @args) { + $disabled = $ERRORS->{DISABLED_FUNCARGS}; + } + elsif ($self->{disable}->{function_restrict} and $torun !~ /$self->{disable}->{function_restrict}/) { + $disabled = sprintf $ERRORS->{DISABLED_FUNCRE}, $torun; + } + + if ($disabled) { + push @err, $disabled; + } + else { + my $func = substr($torun, rindex($torun, '::') + 2); + (my $pkg = $package) =~ s,::,/,g; + until ($ok) { + local ($@, $SIG{__DIE__}); + eval { require "$pkg.pm" }; + if ($@) { + push @err, $@; + } + elsif (defined(&{$package . '::' . $func}) + or defined &{$package . '::AUTOLOAD'} and defined %{$package . '::COMPILE'} and exists ${$package . '::COMPILE'}{$func} + ) { + $ok = 1; + $code = \&{$package . '::' . $func}; + last; + } + else { + push @err, sprintf($ERRORS->{NOSUB}, "$package\::$func", "$pkg.pm"); + } + my $pos = rindex($pkg, '/'); + $pos == -1 ? last : (substr($pkg, $pos) = ""); + last unless $self->{pkg_chop}; + } + } + } + elsif (ref $self->{VARS}->{$torun} eq 'CODE') { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun}; + $ok = 1; + } + } + elsif ($self->{DELAY_VARS}->{$torun}) { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun} = $self->{DELAY_VARS}->{$torun}->{$torun}; + delete $self->{DELAY_VARS}->{$torun}; + $ok = 1; + } + } + + if ($ok) { + local $PARSER = $self; + if ($self->{opt}->{heap}) { + push @args, $self->{opt}->{heap} + } + if ($package and ref($self->{opt}->{func_code}) eq 'CODE') { + $ret = $self->{opt}->{func_code}->($torun, @args); + } + else { + $ret = $code->(@args); + } + if (ref $ret eq 'HASH') { + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + $ret = ''; + } + } + elsif ($package) { + $ret = $self->{opt}->{strict} ? \sprintf($ERRORS->{CANTLOAD}, $package, join(",
        \n", @err)) : ''; + } + else { + if (@err) { + $ret = $self->{opt}->{strict} ? \sprintf($ERRORS->{CANTCALLCODE}, $torun, join(",
        \n", @err)) : ''; + } + else { + $ret = $self->{opt}->{strict} ? \sprintf($ERRORS->{NOTCODEREF}, $torun) : ''; + } + } + + $ret = '' if not defined $ret; + $ret = (ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE') ? $$ret : $self->{opt}->{escape} ? GT::CGI::html_escape($ret) : $ret; + return $ret; +} +END_OF_SUB + +$COMPILE{_compress} = __LINE__ . <<'END_OF_SUB'; +sub _compress { +# ----------------------------------------------------------------------------- +# Compress html by removing extra space (idea/some re from HTML::Clean). +# Avoids compressing pre tags. +# + my ($self, $text) = @_; + if ($$text =~ /))( + my $html = $1; + my $pre = $2 || ''; + $html =~ s/\s+\n/\n/g; + $html =~ s/\n\s+\s{2,} />/g; + $html =~ s/<\s+/\s{2,} />/g; + $$text =~ s/<\s+/{ALIAS}->{$str}) { + $ret = $self->_call_func($str); + } + elsif (my ($val) = $self->_raw_value($str)) { + if (ref $val eq 'CODE') { + local $PARSER = $self; + $ret = $val->($self->vars, $self->{opt}->{heap} || ()); + + $ret = '' if not defined $ret; + } + else { + $ret = $val; + $ret = '' if not defined $ret; + } + } + elsif ($str eq 'TIME') { + return time; + } + else { + $good = 0; + } + + if (not $good) { + return $strict ? sprintf($ERRORS->{UNKNOWNTAG}, $str) : undef; + } + if (ref $ret eq 'HASH') { + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + return; + } + return if not defined $ret; + return $$ret if ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE'; + return $ret if not $escape; + $ret =~ s/&/&/g; + $ret =~ s//>/g; + $ret =~ s/"/"/g; + return $ret; +} + +sub _raw_value { +# ----------------------------------------------------------------------------- +# Gets a raw value. If the variable doesn't exist, returns an empty list (or +# undef, in scalar context). +# + my ($self, $key) = @_; + if (exists $self->{VARS}->{$key} and $self->{DELAY_VARS}->{$key}) { + $self->{VARS}->{$key} = $self->{DELAY_VARS}->{$key}->{$key}; + delete $self->{DELAY_VARS}->{$key}; + } + return $self->{VARS}->{$key} if exists $self->{VARS}->{$key}; + return time if $key eq 'TIME'; + + if ($key =~ /^\w+(?:\.\$?\w+)+$/) { + my $cur = $self->{VARS}; + my @k = split /\./, $key; + for (my $i = 0; $i < @k; $i++) { + if ($k[$i] =~ /^\$/) { + my $val = $self->_get_var(substr($k[$i], 1)); + $val = '' if not defined $val; + my @pieces = split /\./, $val; + @pieces = '' if !@pieces; + splice @k, $i, 1, @pieces; + $i += @pieces - 1 if @pieces > 1; + } + } + while (@k) { + # for a.b.c: + # @k = ('a', 'b', 'c') + # @i = ('a.b.c', 'a.b', 'a') + # This is needed because "a.b.c" will look for key "b.c" in hash "a" before key "b" + my @i = map join('.', @k[0 .. $_]), reverse 1 .. $#k; + push @i, shift @k; + + if (ref $cur eq 'ARRAY' and $i[-1] =~ /^\d+$/) { + return if $i[-1] > $#$cur; + $cur = $cur->[$i[-1]]; + } + elsif (!@k and ref $cur eq 'ARRAY' and $i[0] eq 'length') { + $cur = scalar @$cur; + } + elsif (ref $cur eq 'HASH' or UNIVERSAL::isa($cur, 'GT::Config')) { + my $exists; + for (0 .. $#i) { + if (exists $cur->{$i[$_]}) { + splice @k, 0, $#i-$_ unless $_ == $#i; + $cur = $cur->{$i[$_]}; + $exists = 1; + last; + } + } + return unless $exists; + } + elsif (UNIVERSAL::isa($cur, 'GT::CGI') and my ($val) = $cur->param($i[0])) { + $cur = $val; + last; + } + else { + return; + } + } + + return $cur; + } + + return; +} + +sub _include { +# ----------------------------------------------------------------------------- +# Perform a runtime include of a file. +# + my ($self, $template, $allow_path) = @_; + if ($template eq '.' or $template eq '..' or ($template =~ m{[/\\]} and !$allow_path)) { + return sprintf $ERRORS->{BADINC}, $template, 'Invalid characters in filename'; + } + + if (++$self->{include_safety} > GT::Template::INCLUDE_LIMIT) { + return $ERRORS->{DEEPINC}; + } + + $self->load_template($template) unless $self->{skip_mod_check}->{$template}++; + + my $opt = $self->{opt}; + my $print = $self->{print}; + $self->debug("Parsing dynamic include '$template' with (print => @{[$opt->{print}||0]}, compress => @{[$opt->{compress}||0]}, strict => @{[$opt->{strict}||0]}, escape => @{[$opt->{escape}||0]})") if $self->{_debug}; + + my $ret = $self->_parse($template, $opt); + + --$self->{include_safety}; + + return $ret || ''; +} + +1; + +__END__ + +=head1 NAME + +GT::Template - Gossamer Threads template parser + +=head1 SYNOPSIS + + use GT::Template; + my $var = GT::Template->parse('file.txt', { key => 'value' }); + ... + print $var; + +or + + use GT::Template; + GT::Template->parse_print('file.txt', { key => 'value' }); + +or + + use GT::Template; + GT::Template->parse_stream('file.txt', { key => 'value' }); + +=head1 DESCRIPTION + +GT::Template provides a simple way (one line) to parse a template (which +can be either a file or a string) and make sophisticated replacements. + +It supports simple replacements, conditionals, function calls, including other +templates, and more. + +Additionally, through using pre-compiled files, subsequent parses of a template +will be very fast. + +=head2 Template Syntax + +The template syntax documentation has moved - it is now documented in +L. + +=head2 parse + +This option parses a template, and returns the value of the parsed template. +See L for a description of the possible parse parameters. + +=head2 parse_print + +This option parses a template, and prints it. See L for a +description of the possible parse_print parameters. + +=head2 parse_stream + +This option parses a template, and prints each part of it as the parse occurs. +It should only be used in situations where streaming content is required as it +is measurably slower than the parse_print alternative. See L +for a description of the possible parse_stream parameters. + +=head2 Parse Options + +=head3 Filename + +The first argument to parse()/parse_print()/parse_stream() (hereafter referred +to simply as parse()) is the full or relative (to the current working +directory) path to the file to parse. + +=head3 Variables + +The second argument is a hash reference of template variables that will be +available in the parsed template (see L). Arbitrary +hash/array data structure access is supported (see +L). + +Loops are supported by providing an array reference or code reference as a +value; array reference loops are generally preferred as they enable the loop to +be used multiple times and support the <%loopvar.length%> syntax. + +=head3 Options + +The third argument (which is not required) takes additional options that change +the way a parse is performed. The available options (there are more, however +their use is discouraged) are as follows. + +=over 4 + +=item * string => $template + +Passing in C $template> will use $template as for the template +content instead of reading the file specified as the first parse() argument. +If provided, the first argument to parse() (the filename) is ignored. + +=item * compress => 1 + +Setting compress => 1 will compress all white space generated by the program. +This is usually acceptable for HTML, reducing page sizes by typically 10-20%, +but should not be used for non-HTML templates. The default is 0 (no +compression). This option has no effect when using parse_stream(). + +=item * strict => 0 + +If set to 1, attempting to use a tag that does not exist will display an +"Unknown tag 'tagname'" error. If strict is set to 0, using an unset tag will +not display anything. + +=item * escape => 1 + +If enabled, this option will cause all variables to be HTML escaped before +being included on a page. Enabling this option is strongly recommended. +all variables before they are printed. Tag values that should not be escaped +should be passed as scalar references (\$foo or \''). + +This option currently defaults to 0, but may eventually change to 1 - so +passing an explicit 1 or 0 value is strongly recommended. + +=item * disable => { ... } + +This can be used to disable certain GT::Template functionality. To disable a +particular feature, the hash reference passed to disable should contain a +C with a C<1> value, unless otherwise indicated. Feature names +are as follows: + +=over 4 + +=item * functions + +This can be used to disable Package::function calls, such as +C%Some::Package::function%E>. Note, however, that this does _not_ +disable aliased function calls (see below). + +=item * function_args + +This disables any function calls that specify arguments - for instance, +C%Some::Package::function(1)E>. Note that this does _not_ disable +passing arguments to aliased function calls (see below). + +=item * function_restrict + +This can be used to restrict function calls by limiting the available +functions. It takes a regular expression as an argument, which will be tested +against the fully qualified function name - any function that does not match +the regular expression will not be called. For example, to only allow +functions in 'Package::One' and 'Second::Package' to be called, you could use: + + function_restrict => '^(?:Package::One|Second::Package)::\w+$' + +Like the above options, this does not restrict aliased function calls. + +=item * coderefs_args + +This can be specified to disable the calling of code reference variables with +arguments. Tags such as C%coderefname%E> and +C%coderefname()%E> will be allowed, but C%coderefname(1)%E> +will not. + +=item * alias_args + +This option can be used to disable the passing of arguments to aliased function +calls (see below). + +=back + +=item * pkg_chop + +When calling a function such as <%Package::A::B::function%>, GT::Template will +first attempt to load Package/A/B.pm, then, if it fails, Package/A.pm, and so +on down to Package.pm, looking for Package::A::B::function in each file. This +behaviour is slow and often undesirable - it is recommended to properly split +up packages (that is, putting Package::A::B inside Package/A/B.pm instead of +Package/A.pm or Package.pm). The "package chopping" occurs if pkg_chop is set +to 1 (currently the default, but may change), and does not occur if pkg_chop is +set to 0 (recommended, but not the default for historic reasons). + +=item * heap + +If this is set, it will be added to the end of any other arguments passed to +functions called. + +=item * func_code + +When calling a function such as <%Package::function%>, you can override the +default behaviour of simply calling the function by providing a code reference +to C. Instead of calling Package::function(), your code reference +will be called with the string of the package to call (e.g. +'Package::function') and the arguments that would have been passed to the +function. The return value of your code will be used as if it was the return +value from the real function. + +=item * begin + +=item * end + +C and C can be used to change the characters that start and end a +template tag. These default to C%> for C, and C<%E> for +C. For example, if you changed C to C<[*> and C to C<*]>, you +would use C<[*tagname*]> for a normal tag, C<[*-- comment --*]> for a comment, +etc. + +=back + +=head3 Aliases + +The forth option to parse is an optional hash of aliases to set up for +functions. The key should be the alias name and the value should be the +function to call when the alias is invoked. For example: + + print GT::Template->parse( + 'file.htm', + { key => 'value' }, + { compress => 1 }, + { myfunc => 'Long::Package::Name::To::myfunc' } + ); + +Now in your template you can do: + + <%myfunc('argument')%> + +Which will call C. + +=head2 vars + +Accessing variables from outside a template can be done by calling the +Cvars> method. For further details, please see +L. + +=head1 EXAMPLES + +Parse the string contained in $template, making the 'key' tag available. + + my $parsed = GT::Template->parse(undef, { key => 'value' }, { string => $template }); + +Parse file.txt, compress the result, and print it. This is equivelant to +Cparse(...)>, but slightly faster. + + GT::Template->parse_print('file.txt', { key => 'value' }, { compress => 1 }); + +Print the output of the template it as it is parsed, not after entirely parsed. +This will output the same as the above command would without the "compress" +option, but is slower (unless, of course, streaming is needed). + + GT::Template->parse_stream('file.txt', { key => 'value' }); + +Don't display warnings on invalid keys: + + GT::Template->parse_print('file.txt', { key => 'value' }, { strict => 0 }); + +=head1 SEE ALSO + +L - Documentation/tutorial for GT::Template template +tags. + +L - Interface for accessing/manipulating template tags from +Perl code. + +L - Documentation for GT::Template template +inheritance. + +=head1 COPYRIGHT + +Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Template.pm,v 2.142 2005/07/05 00:39:40 jagerman Exp $ + +=cut diff --git a/site/glist/lib/GT/Template/Editor.pm b/site/glist/lib/GT/Template/Editor.pm new file mode 100644 index 0000000..025f524 --- /dev/null +++ b/site/glist/lib/GT/Template/Editor.pm @@ -0,0 +1,417 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Template::Editor +# Author: Alex Krohn +# CVS Info : +# $Id: Editor.pm,v 2.19 2004/10/19 23:34:44 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# A module for editing templates via an HTML browser. +# + +package GT::Template::Editor; +# =============================================================== +use strict; +use GT::Base; +use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS); +@ISA = qw/GT::Base/; +$VERSION = sprintf "%d.%03d", q$Revision: 2.19 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0; +$ATTRIBS = { + cgi => undef, + root => undef, + backup => undef, + default_dir => '', + default_file => '', + date_format => '', + class => undef, + skip_dir => undef, + skip_file => undef, + select_dir => 'tpl_dir', + demo => undef +}; +$ERRORS = { + CANTOVERWRITE => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.", + CANTCREATE => "Unable to create new files in directory %s. Please set permissions properly and save again.", + CANTMOVE => "Unable to move file %s to %s: %s", + CANTMOVE => "Unable to copy file %s to %s: %s", + FILECOPY => "File::Copy is required in order to make backups.", +}; + +sub process { +# ------------------------------------------------------------------ +# Loads the template editor. +# + my $self = shift; + + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || ''; + my $tpl_text = ''; + my $error_msg = ''; + my $success_msg = ''; + my ($local, $restore) = (0, 0); + +# Check the template directory and file + if ($selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..') { + $error_msg = "Invalid template directory $selected_dir"; + $selected_dir = ''; + $selected_file = ''; + } + if ($selected_file =~ m[[\\/\x00-\x1f]]) { + $error_msg = "Invalid template $selected_file"; + $selected_dir = ''; + $selected_file = ''; + } + +# Create the local directory if it doesn't exist. + my $tpl_dir = $self->{root} . '/' . $selected_dir; + my $local_dir = $tpl_dir . "/local"; + if ($selected_dir and ! -d $local_dir) { + mkdir($local_dir, 0777) or return $self->error('MKDIR', 'FATAL', $local_dir, "$!"); + chmod(0777, $local_dir); + } + my $dir = $local_dir; + + my $save = $self->{cgi}->param('tpl_name') || $self->{cgi}->param('tpl_file'); +# Perform a save if requested. + if ($self->{cgi}->param('saveas') and $save and !$self->{demo}) { + $tpl_text = $self->{cgi}->param('tpl_text'); + if (-e "$dir/$save" and ! -w _) { + $error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $save); + } + elsif (! -e _ and ! -w $dir) { + $error_msg = sprintf($ERRORS->{CANTCREATE}, $dir); + } + else { + if ($self->{backup} and -e "$dir/$save") { + $self->copy("$dir/$save", "$dir/$save.bak"); + } + local *FILE; + open (FILE, "> $dir/$save") or return $self->error(CANTOPEN => FATAL => "$dir/$save", "$!"); + $tpl_text =~ s/\r\n/\n/g; + print FILE $tpl_text; + close FILE; + chmod 0666, "$dir/$save"; + $success_msg = "File has been successfully saved."; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$save"; + $selected_file = $save; + $tpl_text = ''; + } + } +# Delete a local template (thereby restoring the system template) + elsif (my $restore = $self->{cgi}->param("restore") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$restore", "$dir/$restore.bak")) { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!"; + } + } + else { + if (unlink "$dir/$restore") { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to remove $dir/$restore: $!"; + } + } + } +# Delete a local template (This is like restore, but happens when there is no system template) + elsif (my $delete = $self->{cgi}->param("delete") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$delete", "$dir/$delete.bak")) { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!"; + } + } + else { + if (unlink "$dir/$delete") { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to remove $dir/$delete: $!"; + } + } + } + +# Load any selected template file. + if ($selected_file and ! $tpl_text) { + if (-f "$dir/$selected_file") { + local (*FILE, $/); + open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$selected_file"; + } + elsif (-f "$self->{root}/$selected_dir/$selected_file") { + local (*FILE, $/); + open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + } + else { + $selected_file = ''; + } + } + +# Load a README if it exists. + my $readme; + if (-e "$dir/README") { + local (*FILE, $/); + open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)"; + $readme = ; + close FILE; + } + +# Set the textarea width and height. + my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 15; + my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 55; + my $file_select = $self->template_file_select; + my $dir_select = $self->template_dir_select; + $tpl_text = $self->{cgi}->html_escape($tpl_text); + my $stats = $selected_file ? $self->template_file_stats($selected_file) : {}; + + if ($self->{demo} and ($self->{cgi}->param('saveas') or $self->{cgi}->param("delete") or $self->{cgi}->param("restore"))) { + $error_msg = 'This feature has been disabled in the demo!'; + } + return { + tpl_name => $selected_file, + tpl_file => $selected_file, + local => $local, + restore => $restore, + tpl_text => \$tpl_text, + error_message => $error_msg, + success_message => $success_msg, + tpl_dir => $selected_dir, + readme => $readme, + editor_rows => $editor_rows, + editor_cols => $editor_cols, + dir_select => $dir_select, + file_select => $file_select, + %$stats + }; +} + +sub _skip_files { + my ($skip, $file) = @_; + return 1 if $skip->{$file} + or substr($file, 0, 1) eq '.' # skip dotfiles + or substr($file, -4) eq '.bak'; # skip .bak files + foreach my $f (keys %$skip) { + my $match = quotemeta $f; + $match =~ s/\\\*/.*/g; + $match =~ s/\\\?/./g; + return 1 if $file =~ /^$match$/; + } + return; +} + +sub template_file_select { +# ------------------------------------------------------------------ +# Returns a select list of templates in a given dir. +# + my $self = shift; + my $path = $self->{root}; + my %files; + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || $self->{default_file} || 'default'; + $selected_file = $self->{cgi}->param('tpl_name') if $self->{cgi}->param('saveas'); + my %skip; + if ($self->{skip_file}) { + for (@{$self->{skip_file}}) { + $skip{$_}++; + } + } + else { + $skip{README} = $skip{'language.txt'} = $skip{'globals.txt'} = 1; + } + +# Check the template directory + return if $selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..'; + + my $system_dir = $path . "/" . $selected_dir; + my $local_dir = $path . "/" . $selected_dir . '/local'; + foreach my $dir ($system_dir, $local_dir) { + opendir (TPL, $dir) or next; + while (defined(my $file = readdir TPL)) { + next unless -f "$dir/$file" and -r _; + next if _skip_files(\%skip, $file); + + $files{$file} = 1; + } + closedir TPL; + } + my $f_select_list = '{class}; + $d_select_list .= ">\n"; + foreach (sort @dirs) { + $d_select_list .= qq'
        {cfg}{template}' template set. +# Generated on: [localtime] + +HEADER + $LANG_TPL = $self->{cfg}{template}; + + if (exists $LANGUAGE->{$code}) { + return @_ ? sprintf($LANGUAGE->{$code}, @_) : $LANGUAGE->{$code}; + } + else { + return $code; + } +} + +sub fatal { +# Return a fatal error message to the browser. +# + die @_ if (GT::Base->in_eval()); # Don't do anything if we are in eval. + + my $in = new GT::CGI; + my $msg = $in->html_escape(shift); + my $font = "Tahoma,Arial,Helvetica"; + + print $in->header; + print qq! + A fatal error has occurred:
        $msg
        Please enable debugging in setup for more details.
        \n + !; + print base_env($in) if $DEBUG; +} + +sub base_env { + my ($in, $version, $commands) = @_; + + my $info = '
        ';
        +    my ($oserr, $evalerr) = ($@, $!);
        +
        +# Stack trace.
        +    $info .= "Stack Trace\n======================================\n";
        +    $info .= GT::Base::stack_trace('FileMan', 1);
        +    $info .= "\n";
        +
        +# Print GT::SQL error if it exists.
        +    $info .= "System Information\n======================================\n";
        +    if (my @user = eval { getpwuid($>) }) {
        +        $info .= "Current user: $user[0] ($>)\n";
        +    }
        +    $info .= "Perl version: " . ($^V ? sprintf("%vd", $^V) : $]) . "\n";
        +    $info .= "Gossamer FileMan Version: $version\n" if $version;
        +    $info .= "GT::Template version: $GT::Template::VERSION\n" if $GT::Template::VERSION;
        +    $info .= "Running under mod_perl: " . (MOD_PERL ? "Yes (version " . MOD_PERL . ")" . (MOD_PERL >= 1.99 ? ', mod_perl 2 detected' : '') : "No") . "\n";
        +    $info .= "Running under SpeedyCGI: " . (SPEEDY ? "Yes (version " . SPEEDY . ")" : "No") . "\n";
        +    $info .= "\@INC = \n\t" . join("\n\t", @INC) . "\n";
        +    $info .= "\$\@: " . $in->html_escape($oserr) . "\n" if $oserr;
        +    $info .= "\$!: " . $in->html_escape($evalerr) . "\n" if $evalerr;
        +    $info .= "\n";
        +
        +    if ($commands) {
        +        $info .= 'Commands: ';
        +        foreach (keys %$commands) {
        +            $info .= qq||;
        +        }
        +        $info .= '
        $_:| . ($commands->{$_} ? 'Enabled' : 'Disabled') . qq|

        '; + $info .= "\n"; + } + +# CGI Parameters and Cookies. + if (ref $in eq 'GT::CGI') { + if ($in->param) { + $info .= "CGI Input\n======================================\n"; + foreach (sort $in->param) { + $info .= $in->html_escape($_) . " => " . $in->html_escape($in->param($_)) . "\n"; + } + $info .= "\n"; + } + if ($in->cookie) { + $info .= "CGI Cookies\n======================================\n"; + foreach (sort $in->cookie) { + $info .= $in->html_escape($_) . " => " . $in->html_escape($in->cookie($_)) . "\n"; + } + $info .= "\n"; + } + } + +# Environement info. + $info .= "Environment\n======================================\n"; + foreach (sort keys %ENV) { + $info .= $in->html_escape($_) . " => " . $in->html_escape($ENV{$_}) . "\n"; + } + + $info .= "
        "; + return $info; +} + +sub globals { + my $self = shift; + +# Create css and js url + $self->{cfg}{template} = $self->{cgi}{t} if $self->{cgi}{t}; + my $date_input = $self->{cfg}{date}{input}; + $date_input =~ s/%//g; + $self->{cfg}{date_input} = $date_input; + + my %g = (cfg => $self->{cfg}, in => $self->{cgi}, default => $self->{default}, session => $self->{session}); + + my $hiddens = $self->hiddens(); + foreach (keys %$hiddens) { + $g{$_} = \$hiddens->{$_}; + } + +# Reload user's diskspace. This applies for multiple users version only + if ($self->{cfg}{fversion} eq 'multiple' and !$self->{session}{user}{type}) { + my @paths = map $_->{name}, @{$self->{session}{user}{accesses_loop}}; + $self->{diskspace} = $self->check_space(\@paths, $self->{session}{user}{allowed_space}); # Load free space + $g{space} = $self->{diskspace}; + } + + \%g; +} + +sub hiddens { + my ($self, $no_workpath) = @_; + + my @items = qw/sid t/; + + my ($query, $html) = ('', ''); + foreach (@items) { + next unless $self->{cgi}{$_}; + $query .= ";" . $self->{in}->escape($_) . "=" . $self->{in}->escape($self->{cgi}{$_}) if exists $self->{cgi}{$_}; + $html .= qq||; + } + + if ($self->{url_opts}) { + my @opts = split(/;|&/, $self->{url_opts}); + foreach (@opts) { + if ($_ =~ /^(\w+)=(.*\/?\w+)/) { + $query .= ";$1=$2"; + $html .= qq||; + } + } + } + + my $subquery = $query; + unless ($no_workpath) { + $query .= ";work_path=" . $self->{in}->escape($self->{cfg}{work_path}) if $self->{cfg}{work_path}; + $html .= qq||; + } + + return { hidden_query => $query, hidden_subquery => $subquery, hidden_objects => $html }; +} + +sub check_space { + my ($self, $path, $allowed_space) = @_; + + return undef unless $allowed_space and $path; + + my @paths = ref $path eq 'ARRAY' ? @$path : [$path]; + + my ($used_space, $free_space, $usage) = (0, 0, 0); + foreach my $p (@paths) { + find($p, sub { $used_space += -s shift }, { untaint => 1 } ); + } + +# Size in kb + $used_space /= 1024; + $free_space = $allowed_space < $used_space ? 0 : $allowed_space - $used_space; + $usage = $used_space / $allowed_space * 100 if $allowed_space > 0; + return { + free => int($free_space * 1024), + allowed => int($allowed_space * 1024), + used => int($used_space * 1024), + usage => int($usage) + }; +} + +sub image_url { +# Takes an filename and using the current template set and theme, returns +# the url of the image. It first checks if the file exists in the theme's +# image directory, checks the template's image directory, and then tries +# to check the template inheritance tree for more image directories. +# + my $image = shift; + + my $tags = GT::Template->tags; + + if (-e "$tags->{cfg}{static_path}/$tags->{cfg}{template}/images/$image") { + return "$tags->{cfg}{static_url}/$tags->{cfg}{template}/images/$image"; + } + +# The image doesn't exist here, but return it anyway + return "$tags->{cfg}{static_url}/$tags->{cfg}{template}/images/$image"; +} + +sub encrypt { +#-------------------------------------------------------------------- +# Encrypt password +# + my ($clear_pass, $salt) = @_; + $salt ||= join '', map +('a' .. 'z', 'A' .. 'Z', 0 .. 9, '.', '/')[rand 64], 1 .. 8; + + require GT::MD5::Crypt; + return GT::MD5::Crypt::gt_md5_crypt($clear_pass, $salt); +} + +sub check_action { + my ($self, $action) = @_; + + my $perm = $self->{cfg}{fversion} eq 'multiple' ? $self->{session}{user}{permission} : $self->{cfg}{permission}; + return exists $perm->{$action} ? $perm->{$action} : 1; +} +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands.pm b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands.pm new file mode 100644 index 0000000..37368b6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands.pm @@ -0,0 +1,2383 @@ +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::FileMan::Commands +# CVS Info : 087,071,086,086,085 +# $Id: Commands.pm,v 1.383 2008/11/27 07:06:56 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::FileMan::Commands; + +use strict; +use vars qw/%ICONS $READ_SIZE/; +use GT::TempFile; +use GT::Base qw/:persist/; +use GT::AutoLoader; +use GT::File::Tools qw/:all/; +use GT::Date; +use Cwd; + +use constants KB => 1024, MB => 1024 * 1024, FOLDER => 1, FILE => 2, SYMLINK => 3; + +%ICONS = ( + 'gif jpg jpeg bmp' => ['image' => 'Image File'], + 'txt' => ['txt' => 'Text File'], + 'cgi pl pm' => ['perl' => 'Script File'], + 'zip gz tar' => ['compressed' => 'Compressed File'], + 'htm html shtm shtml' => ['html' => 'HTML File'], + 'wav au mid mod mp3 wmv'=> ['audio' => 'Sound File'], + 'exe' => ['exe' => 'Binary File'], + 'doc' => ['doc' => 'MS Word'], + 'xls' => ['xls' => 'MS Excel'], + 'pdf' => ['pdf' => 'Adobe Acrobat'], + 'unknown' => ['unknown' => 'Unknown'], + 'folder' => ['folder' => 'File Folder'], + 'symlink' => ['symlink' => 'Symlink'] +); + +# How large a chunk should we read into memory at once. +$READ_SIZE = 500000; + +$COMPILE{home} = __LINE__ . <<'END_OF_SUB'; +sub home { +# ----------------------------------------------------------------------------- +# Print out the home page +# + my ($self, %args) = @_; + + my $page = $self->{cgi}{page} || ''; + if ($page =~ /^help(_\w*)?.html/) { + return $self->print($page); + } + ($self->{cgi}{ajax} and $args{error} and lc $ENV{REQUEST_METHOD} eq 'post') ? $self->print_json_error($args{error}) : $self->print('home.html', \%args); +} +END_OF_SUB + +$COMPILE{password} = __LINE__ . <<'END_OF_SUB'; +sub password { +# ----------------------------------------------------------------------------- +# Change password feature which is for single user version +# + my $self = shift; + + return $self->print_json({ html => $self->print('password.html', { json => 1 }) }, 1) if $self->{cgi}{form}; + + my $old = $self->{cgi}{old_password}; + my $new = $self->{cgi}{new_password}; + my $confirm = $self->{cgi}{confirm_password}; + + return $self->print_json_error($self->language('ERR_PASSWD_INPUT')) unless $old and $new and $confirm; + return $self->print_json_error($self->language('ERR_INVALID_OLDPASSWD')) if $self->{cfg}{login}{password} ne crypt($old, $self->{cfg}{login}{password}) and $self->{cfg}{login}{password} ne GT::FileMan::encrypt($old, $self->{cfg}{login}{password}); + return $self->print_json_error($self->language('ERR_PASSWD_NOMATCH')) if $new ne $confirm; + + $self->{cfg}{login}{password} = GT::FileMan::encrypt($new); + $self->{cfg}->save(); + + $self->print_json(undef, 1, $self->language('MSG_PASSWD_UPDATED')); +} +END_OF_SUB + +$COMPILE{cd} = __LINE__ . <<'END_OF_SUB'; +sub cd { +# ----------------------------------------------------------------------------- +# CD command. This must be a post request +# + my $self = shift; + + my $dname = $self->{cgi}{f}; + my $path = $self->check_path($dname); + + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $dname)) unless $path->{exist}; + + $self->{cfg}{work_path} = $path->{work_path}; + +# Loading files + my $files = $self->files; + return $self->print_json_error($files) if ref $files ne 'HASH'; + + $self->print_json($files, 1); +} + +sub files { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $fpath = $self->check_path(); + return $self->language($fpath->{error}) if $fpath->{error}; + + my $path = $fpath->{full_path}; + opendir (DIR, $path) or return $self->language('ERR_CANNOT_OPEN', $path, $!); + my @rows = readdir(DIR); + close DIR; + + my (@files, $readme); + my $size = 0; + foreach my $f (@rows) { + next if ($f eq '.' or $f eq '..'); + next if ($f =~ /^\./ and !$self->{default}{show_hidden}); + + my $file = $self->finfo("$path/$f", $f); + if ($self->{cgi}{filter} == 1 and $file->[0] != FOLDER) { + next; + } + elsif ($self->{cgi}{filter} == 2 and $file->[0] != FOLDER and !-T "$path/$f") { + next; + } + + push @files, $file; + $size += $file->[3]; + $readme = $f if lc $f eq 'readme'; + } + +# loading current path and hidden objects + my $hiddens = $self->hiddens(); + my $paths = $self->current_path(); + +# Loading .htaccess and .htpassword + my $htaccess_users = $self->load_htpasswd(); + my $readme_content = ''; + if ($self->{default}{readme} != 3 and $readme) { + if (open(README, "< $path/$readme")) { + my $count = 0; + while () { + chomp; + next unless $_; + $readme_content .= "$_\n"; + $count++; + last if $count == 10; + } + close README; + } + } + return { + hits => scalar @files, + files => \@files, + size => $size, + paths => $paths, + hiddens => $hiddens, + root_path => $self->{session}{user} ? $self->{session}{user}{current}{disp} : undef, + htaccess_users => $htaccess_users, + readme_content => $self->{in}->html_escape($readme_content) + }; +} + +END_OF_SUB + +$COMPILE{search} = __LINE__ . <<'END_OF_SUB'; +sub search { + my $self = shift; + + return $self->print_json({ html => $self->print('search.html', { json => 1 }) }, 1) if $self->{cgi}{form}; + + my $result = $self->fsearch(); + return $self->print_json_error($result->{error}) if $result->{error}; + + $self->flog("search|Search for: '$self->{cgi}{search_input}'"); + $self->print_json($result, 1, $self->language('MSG_SEARCH', $result->{hits})); +} + +sub fsearch { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $ftype = $self->{cgi}{search_type}; + my $fmodified = $self->{cgi}{search_mod}; + my $from_date = $self->{cgi}{fromdate}; + my $to_date = $self->{cgi}{todate}; + + require GT::Date; + if ($fmodified eq 'past_week') { + $from_date = GT::Date::date_get(time - (7 * 86400), $self->{cfg}{date}{input}); + $to_date = GT::Date::date_get(time, $self->{cfg}{date}{input}); + } + elsif ($fmodified eq 'past_month') { + $from_date = GT::Date::date_get(time - (30 * 86400), $self->{cfg}{date}{input}); + $to_date = GT::Date::date_get(time, $self->{cfg}{date}{input}); + } + elsif ($fmodified eq 'past_year') { + $from_date = GT::Date::date_get(time - (365 * 86400)); + $to_date = GT::Date::date_get(time, $self->{cfg}{date}{input}); + } + + return { error => $self->language('ERR_SEARCH_COND') } unless $self->{cgi}{search_input} or $from_date or $to_date or $ftype; + + my (@files, @results); + unless ($self->{cgi}{search_scope}) { + my $fpath = $self->check_path(); + unless ($fpath->{error}) { + find($fpath->{full_path}, sub { push @files, shift }, { untaint => 1 }); + } + } + else { + my @selecteds = $self->{in}->param('cinput'); + foreach (@selecteds) { + my $fpath = $self->check_name($_); + next if $fpath->{error}; + + if ($fpath->{isfile}) { + push @files, $fpath->{full_path}; + } + else { + find($fpath->{full_path}, sub { push @files, shift }, { untaint => 1 }); + } + } + } + + my $src_term = $self->{cgi}{search_input} || ''; + if (not $self->{cgi}{search_exp}) { + $src_term = quotemeta($src_term); + $src_term =~ s/\\\*/.*/g; + $src_term =~ s/\\\?/./g; + } + $src_term = "(?i)$src_term" unless $self->{cgi}{search_case}; + +# Search file and directory names + my $total_size = 0; + unless ($self->{cgi}{search_content}) { + $ftype =~ s/^\s+//; + $ftype =~ s/\s+$//; + my %ftype = map { $_ => 1 } split /\s*,\s*/, $ftype; + + foreach my $file (@files) { + my ($fn) = $file =~ m,/([^/]+)$,; + next if $fn eq $self->{work_path} or $fn !~ /$src_term/; + + if ($ftype) { + my ($ext) = $fn =~ /\.([^.]+)$/; + next unless $ext and $ftype{$ext}; + } + + my $f = $self->finfo($file, $fn); + next unless scalar @$f; + +# Search on modify date + if ($fmodified) { + my $modified = GT::Date::date_get($f->[5], $self->{cfg}{date}{input}); + if ($from_date and $to_date) { + next if GT::Date::date_is_smaller($modified, $from_date) or GT::Date::date_is_greater($modified, $to_date); + } + else { + next if ($from_date and $modified ne $from_date) or ($to_date and $modified ne $to_date); + } + } + + push @results, $f; + $total_size += $f->[3]; + } + } +# Search file contents + else { + foreach my $file (@files) { +# Only search the contents of files that are readable, have content and are non-binary + next unless -f $file and -r _ and -s _ and -T _; + my ($ext) = $file =~ /\.([^.]+)$/; + my ($fn) = $file =~ m,/([^/]+)$,; +# pdf files look like text files + next if lc $ext eq 'pdf'; + + open(DATA, "<$file") or next; + my ($buffer, $f, $bit); + while (my $rs = read DATA, $buffer, $READ_SIZE) { + $buffer = "$bit$buffer" if length $bit; + $bit = ($rs == $READ_SIZE and $buffer =~ s/(?:\r|\r?\n)([^\r\n]+)$//) ? $1 : ''; + + if ($buffer =~ /$src_term/) { + $f = $self->finfo($file, $fn); + last; + } + } + close DATA; + next unless $f; + + push @results, $f; + $total_size += $f->[3]; + } + } + + return { files => \@results, hits => scalar @results, size => $total_size }; +} +END_OF_SUB + +$COMPILE{replace} = __LINE__ . <<'END_OF_SUB'; +sub replace { +# ----------------------------------------------------------------------------- +# Replace contents of text files +# + my $self = shift; + + return $self->print_json_error($self->language('ERR_SEARCH_COND')) unless $self->{cgi}{replace_input}; + + my (@files, @results); + unless ($self->{cgi}{replace_scope}) { + my $fpath = $self->check_path(); + unless ($fpath->{error}) { + find($fpath->{full_path}, sub { push @files, shift }, { untaint => 1 }); + } + } + else { + my @selecteds = $self->{in}->param('cinput'); + foreach (@selecteds) { + my $fpath = $self->check_name($_); + + next if $fpath->{error}; + if ($fpath->{isfile}) { + push @files, $fpath->{full_path}; + } + else { + find($fpath->{full_path}, sub { push @files, shift }, { untaint => 1 }); + } + } + } + + my $search_for = $self->{cgi}{replace_input} || ''; + my $replace_with = $self->{cgi}{replace_with} || ''; + + if (not $self->{cgi}{replace_exp}) { + $search_for = quotemeta($search_for); + $search_for =~ s/\\\*/.*/g; + $search_for =~ s/\\\?/./g; + } + + $search_for = "\\b$search_for\\b" if $self->{cgi}{replace_wholeword}; + $search_for = "(?i)$search_for" unless $self->{cgi}{replace_case}; + + my $total_size = 0; + foreach my $file (@files) { +# Only search the contents of files that are readable, have content and are non-binary + next unless -f $file and -r _ and -s _ and -T _; + my ($ext) = $file =~ /\.([^.]+)$/; + my ($fn) = $file =~ m,/([^/]+)$,; + next if lc $ext eq 'pdf'; + + open(DATA, "<$file") or next; + my ($buffer, $f, $bit); + while (my $rs = read DATA, $buffer, $READ_SIZE) { + $buffer = "$bit$buffer" if length $bit; + $bit = ($rs == $READ_SIZE and $buffer =~ s/(?:\r|\r?\n)([^\r\n]+)$//) ? $1 : ''; + + if ($buffer =~ /$search_for/) { + $f++; + last; + } + } + close DATA; + next unless $f; + + my $tempfile = new GT::TempFile; + if (fcopy($file, "$$tempfile.tmp", $search_for, $replace_with)) { + move($file, "$file.bak", { untaint => 1 }) if $self->{cgi}{replace_bak}; + move("$$tempfile.tmp", $file, { untaint => 1 }); + } + + push @results, $self->finfo($file, $fn); + $total_size += -s $file; + +# Log the action + $self->flog("replace|Replace '$search_for' with '$replace_with'"); + } + +# loading current path and hidden objects + my $hiddens = $self->hiddens(); + my $paths = $self->current_path(); + my $hits = scalar @results; + + $self->print_json({ + hits => $hits, + files => \@results, + size => $total_size, + hiddens => $hiddens, + paths => $paths + }, 1, $self->language('MSG_REPLACED', $hits)); +} +END_OF_SUB + +$COMPILE{command} = __LINE__ . <<'END_OF_SUB'; +sub command { +# ----------------------------------------------------------------------------- +# Execute a command in shell +# + my $self = shift; + +# Untaint PATH + $ENV{PATH} = '/bin:/usr/bin:/usr/local/bin'; + +# Untaint the command + my $command = $self->{cgi}{command_input} || ''; + ($command) = $command =~ /^(.*)$/; + +# Remove serial file which is nolonger used + my $serial = $self->{cgi}{serial}; + ($serial) = $serial =~ /^(\w+)$/; + + if ($self->{cgi}{remove} and $serial) { + unlink "$self->{cfg}{tmp_path}/$serial"; + print $self->{in}->header(-type => 'text/xml; charset=utf8', '-no-cache' => 1); + print qq!\n\ndone\n!; + +# Log the action + $self->flog("command|$command"); + return; + } + +# Change to the working directory and then get the current path to ensure we +# get a 'clean looking' path + my $working_dir = $self->{cgi}{working_dir}; + unless ($working_dir) { + my $fpath = $self->check_path(); + $working_dir = $fpath->{full_path} unless $fpath->{error}; + } + + ($working_dir) = $working_dir =~ /^(.*)$/; + chdir($working_dir); + + $working_dir = cwd(); + + my $prompt = $GT::FileMan::MSWIN ? "$working_dir>" : "[" . eval { getpwuid($<) . '@' } . "$ENV{SERVER_NAME} $working_dir]"; + my $next_prompt = $prompt; + return $self->print_json({ prompt => $prompt, working_dir => $working_dir }, 1) if $self->{cgi}{prompt} and !$self->{cgi}{retrieve}; + return $self->print_json_error($self->language('ERR_COMMAND')) unless $command; + + + my ($output, $error) = ('', ''); + if ($self->{cgi}{retrieve} and $serial) { + if (-f "$self->{cfg}{tmp_path}/$serial") { + open(DATA, "< $self->{cfg}{tmp_path}/$serial"); + read DATA, $output, -s DATA; + close DATA; + } + +# Getting the working directory + if ($command =~ m/^\s*cd\s+(.+)/) { + chdir($1); + $working_dir = cwd(); + $next_prompt = $GT::FileMan::MSWIN ? "$working_dir>" : "[" . eval { getpwuid($<) . '@' } . "$ENV{SERVER_NAME} $working_dir]"; + } + + print $self->{in}->header(-type => 'text/xml; charset=utf8', '-no-cache' => 1); + print qq~\n\n\n\n\n\n~; + return; + } + +# Run the command and send out a temporary file + my $timeout = $self->{cfg}{command_timeout} || 60; + my ($pid, $oldfh); + $SIG{ALRM} = sub { + kill('INT', $pid); + die; + }; + alarm($timeout); + + eval { + $pid = open(TMP, "$command |"); + $oldfh = select(TMP); $| = 1; select($oldfh); + while () { + s/(\n|\r\n)$//; + open DATA, ">> $self->{cfg}{tmp_path}/$serial" or die $!; + print DATA $_. "\n"; + close DATA; + } + close TMP; + }; + open DATA, ">> $self->{cfg}{tmp_path}/$serial" or die $!; + print DATA ($error ? $error : 'done'); + close DATA; +} +END_OF_SUB + +$COMPILE{upload} = __LINE__ . <<'END_OF_SUB'; +sub upload { +# ----------------------------------------------------------------------------- +# Upload a file +# + my $self = shift; + +# Handle upload progress + return $self->upload_progress() if $self->{cgi}{upload}; + + if ($self->{cgi}{num_files}) { + my $num_files = $self->{cgi}{num_files}; + my $uploaded = 0; + my $declined = 0; + my $total_size = 0; + for (my $i = 1; $i <= $num_files; $i++) { + next unless $self->{cgi}{"file-$i"}; + + my %result = $self->fupload($self->{cgi}{"file-$i"}, $self->{cgi}{"mode-$i"}); + if ($result{error}) { + return $self->print_json_error($result{error}) if $num_files == 1; + $declined++; + next; + } + $total_size += $result{size}; + $uploaded++; + + $self->{diskspace}{free} -= $result{size} if $self->{diskspace}; + +# Log the action + $self->flog("upload|$result{name}"); + } + + return $self->print_json(undef, 1, $self->language('MSG_MULT_UPLOADED', $uploaded, friendly_size($total_size), $declined)); + } + else { + my %result = $self->fupload($self->{cgi}{upload_input}, $self->{cgi}{upload_mode}); + return $self->print_json_error($result{error}) if $result{error}; + +# Log the action + $self->flog("upload|$result{name}"); + return $self->print_json(undef, 1, $self->language('MSG_UPLOADED', $result{name}, friendly_size($result{size}))); + } +} + +sub fupload { +# ----------------------------------------------------------------------------- +# + my ($self, $data, $mode) = @_; + + my $fn = $data; + $fn =~ s/.*?([^\\\/:]+)$/$1/; + $fn =~ s/[\[\]\s\$\#\%'"]/\_/g; + + unlink "$self->{cfg}{tmp_path}/$self->{serial}" if $self->{serial}; # Remove the log file + + return (error => $self->language('ERR_NOUPLOAD')) unless $fn; + +# Change the name if format + if ($self->{cgi}{name_format} eq 'uc') { + $fn =~ s/(\w+)/\U$1/gi; + } + elsif ($self->{cgi}{name_format} eq 'lc') { + $fn =~ s/(\w+)/\L$1/gi; + } + + my $file = $self->check_name($fn); + return (error => $file->{error}) if $file->{error}; + + if ($file->{exist}) { + return (error => $self->language('ERR_EXISTING', $fn)) unless $self->{cgi}{opt_overwrite}; + return (error => $self->language('ERR_NOT_WRITABLE', $fn)) unless $file->{write}; + } + else { + my $folder = $self->check_path(undef); + return (error => $folder->{error}) if $folder->{error}; + return (error => $self->language('ERR_NOT_FOUND', $self->{cfg}{work_path})) if $self->{cfg}{work_path} and !$folder->{exist}; + return (error => $self->language('ERR_NOT_WRITABLE', $self->{cfg}{work_path})) unless $folder->{write}; + } + +# Check free space if appicable. If diskspace is null, there is no limit + return (error => $self->language('ERR_NOSPACE')) if $self->{diskspace} and !$self->{diskspace}{free}; + + my $full_path = $file->{full_path}; + + $mode ||= 'auto'; + $mode = lc $mode; + $mode = 'ascii' if $mode eq 'auto' and lc substr($full_path, -4, 4) ne '.pdf' and -T $full_path; + + my ($uploaded_size, $bytesread, $buffer) = (0, 0, ''); + my $newlines = $GT::FileMan::MSWIN ? "\r\n" : "\n"; + open(OUTFILE, "> $full_path"); + binmode OUTFILE; + while ($bytesread = read($data, $buffer, 1024)) { + $buffer =~ s/$newlines/\n/g if $mode eq 'ascii'; + print OUTFILE $buffer; + $uploaded_size += $bytesread; + } + close OUTFILE; + + my $mod = $self->{cfg}{default}{upload_mode} || '644'; + chmod(oct($mod), $full_path); + my $fsize = -s $full_path; + +# Check free space if appicable. If diskspace is null, there is no limit + if ($self->{diskspace} and $self->{diskspace}{free} < $fsize) { + del($full_path, { untaint => 1 }); + return $self->home(error => $self->language('ERR_NOSPACE')); + } + + return (name => $file->{name}, size => $fsize); +} + +END_OF_SUB + + +$COMPILE{file} = __LINE__ . <<'END_OF_SUB'; +sub file { +# Create a new file +# + my $self = shift; + + if ($self->{cgi}{form}) { + $self->print_json({ html => $self->print('editor.html', { json => 1, editor_mode => $self->{default}{editor_mode} ? 'html' : 'text' }) }, 1); + } + else { + $self->edit(); + } +} +END_OF_SUB + +$COMPILE{edit} = __LINE__ . <<'END_OF_SUB'; +sub edit { +# ----------------------------------------------------------------------------- +# Edit a file +# + my $self = shift; + +# Print out editor form + if ($self->{cgi}{form}) { + my $fname = $self->{cgi}{f}; + return $self->print_json_error($self->language('ERR_CANNOT_OPEN_MULT')) if ref $fname eq 'ARRAY'; + + my $file = $self->check_name($fname); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOT_FILE', $file->{name})) unless $file->{isfile}; + return $self->print_json_error($self->language('ERR_NOT_READABLE', $file->{name})) unless $file->{read}; + return $self->open_compressed($file) if $file->{type} eq 'compress'; + return $self->print_json({ file => $file }) unless $file->{type} =~ /text|html/; + +# Get content of the file + open (DATA, "<$file->{full_path}") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + read (DATA, my $content, -s DATA); + close DATA; + + if ($file->{type} eq 'html') { + $file->{content} = $content; + } + else { + $content =~ s,\r\n,\n,g; + $file->{content} = $content; + } + + return $self->print_json({ + html => $self->print('editor.html', { file => $file, editor_mode => ($file->{type} eq 'html' and $self->{default}{editor_mode}) ? 'html' : 'text', json => 1 }), + type => $file->{type}, + }, 1); + } + +# Save file + my $old = $self->{cgi}{file}; + my $content = $self->{cgi}{editor}; + my $mode = $self->{cgi}{editor_mode}; + + return $self->print_json_error($self->language('ERR_NOSPACE')) if ($self->{diskspace} and (!$self->{diskspace}{free} or $self->{diskspace}{free} < length $content)); + +# Save content into a new file + my ($history, $file); + my $fname = $self->{cgi}{edit_input} || $self->{cgi}{file_input}; + if ($fname and $fname ne $old) { + $file = $self->check_name($fname); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error({ file => $file, confirm => 1 }) if $file->{exist} and !$self->{cgi}{overwrite_confirmed}; + + $history = "newfile|$self->{cgi}{name}"; + } + +# Update file with new content + else { + $file = $self->check_name($old); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOT_WRITEABLE', $file->{name})) unless $file->{write}; + + $history = "edit|$old"; + } + + open(DATA, "> $file->{full_path}") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + print DATA $content; + close DATA; + +# Log the action + $self->flog($history); + return $self->print_json(undef, 1, $self->language('MSG_FILE_SAVED', $file->{name})); +} +END_OF_SUB + +$COMPILE{makedir} = __LINE__ . <<'END_OF_SUB'; +sub makedir { +# ----------------------------------------------------------------------------- +# Create a new directory +# + my $self = shift; + + my $dname = $self->{cgi}{makedir_input}; + return $self->print_json_error($self->language('ERR_INVALID_INPUT')) unless $dname; + + my $new = $self->check_name($dname); + + return $self->print_json_error($new->{error}) if $new->{error}; + return $self->print_json_error($self->language('ERR_EXISTING', $dname)) if $new->{exist}; + return $self->print_json_error($self->language('ERR_NOSPACE')) if $self->{diskspace} and !$self->{diskspace}{free}; + + rmkdir($new->{full_path}, 0755, { untaint => 1 }) or return $self->print_json_error($self->language('ERR_MAKDEDIR', $dname, $!)); + $self->flog("makedir|$dname"); + + return $self->print_json(undef, 1, $self->language('MSG_MAKEDIR', $dname)); +} +END_OF_SUB + +$COMPILE{chmod} = __LINE__ . <<'END_OF_SUB'; +sub chmod { +# ----------------------------------------------------------------------------- +# Change the permissions of a file +# + my $self = shift; + +# Change mod + my @files = $self->{in}->param('cinput'); + my $mod = $self->{cgi}{chmod_input}; + + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files; + return $self->print_json_error($self->language('ERR_CHMOD_INPUT')) unless $mod; + +# Untaint permission input + ($mod) = $mod =~ /^([0-7]{3,4})$/; + return $self->print_json_error($self->language('ERR_INVALID_PERM')) unless $mod; + + my $changed = 0; + my $oct_mod = oct($mod); + + foreach my $f (@files) { + my $file = $self->check_name($f); + if ($file->{error}) { + return $self->print_json_error($file->{error}) if scalar @files == 1; # Return if error occurs for a single file + next; + } + + if (-d $file->{full_path} and $self->{cgi}{chmod_recursive}) { + find($file->{full_path}, sub { chmod($oct_mod, shift) }, { untaint => 1 }); + $changed++; + } + else { + chmod($oct_mod, $file->{full_path}) and $changed++; + } + } + return $self->print_json_error('cannot_chmod') unless $changed; + +# Log the action + $self->flog("chmod|" . join(', ', @files)); + $self->print_json(undef, 1, scalar @files == 1 ? $self->language('MSG_CHMODED', $files[0]) : $self->language('MSG_MULT_CHMODED', $changed)); +} +END_OF_SUB + +$COMPILE{protect} = __LINE__ . <<'END_OF_SUB'; +sub protect { +# ----------------------------------------------------------------------------- +# Protect command: create .htaccess file +# + my $self = shift; + + my $pwd_path = $self->{default}{pwd_path}; + my ($htpwd, $htacc, $name_pwd, $name_acc); + +# Create the .htpasswd + if ($pwd_path) { + my $path = $self->check_path($pwd_path); + if (!$path->{error} and $path->{exist}) { + my $current = $self->check_path(); + unless ($current->{error}) { + $current->{full_path} =~ s/[\/ \:]/\_/g; + $htpwd = "$path->{full_path}/.htpass$current->{full_path}"; + ($htpwd) = $htpwd =~ /^(.*)$/; # Untaint the path + } + } + } + + unless ($htpwd) { + my $fpassword = $self->check_name('.htpasswd'); + return $self->print_json_error($fpassword->{error}) if $fpassword->{error}; + $htpwd = $fpassword->{full_path}; + } + + ($name_pwd) = $htpwd =~ /^$self->{cfg}{root_path}\/(.*)/; + + unless (-e $htpwd) { + open (FILE, "> $htpwd") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $name_pwd, $!)); + close FILE; + } + +# Create the .htaccess + my $faccess = $self->check_name('.htaccess'); + return $self->print_json_error($faccess->{error}) if $faccess->{error}; + + $htacc = $faccess->{full_path}; + ($name_acc) = $htacc =~ /^$self->{cfg}{root_path}\/(.*)/; + + unless ($faccess->{exist} and $faccess->{size}) { + my $error = $self->create_htaccess($htacc, $htpwd); + return $self->print_json_error($error) if $error; + } + + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $name_pwd)) unless -w $htpwd; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $name_acc)) unless -w $htacc; + +# Overwrite existing .htaccess if AuthUserFile isn't matching with htpwd + open (HTACC, "< $htacc") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $name_acc, $!)); + my @info = ; + close HTACC; + + my $found; + LINE: foreach (@info) { + if ( $_ =~ /$htpwd/ ) { + $found = 1; + last; + } + } + + unless ($found) { + my $error = $self->create_htaccess($htacc, $htpwd); + return $self->print_json_error($error) if $error; + } + +# Delete all users + if ($self->{cgi}{'protect-delete-all'}) { + unlink $htpwd; + unlink $htacc; + return $self->print_json(undef, 1, $self->language('MSG_MULTUSER_DELETED', 'All')); + } + +# Create/delete a user + my (@users, $msg); + my $username = $self->{cgi}{protect_username}; + my $password = $self->{cgi}{protect_password}; + my $del_user = $self->{cgi}{protect_user}; + + if (-s $htpwd) { + open (HTPWD, "< $htpwd") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $name_pwd, $!)); + @users = grep { $_ !~ /^$del_user:/} ; + close HTPWD; + } + + my $message; + if ($username and $password) { + return $self->print_json_error($self->language('ERR_UID_INVALID', $username)) if $username =~ /:/; + + foreach my $i (0 .. @users) { + my $u = $users[$i]; + if ($u =~ /^$username:/) { + return $self->print_json_error($self->language('ERR_UID_EXISTING', $username)) unless $self->{cgi}{opt_protect_overwrite}; + delete $users[$i]; + } + } + + my $crypted; + if ($self->{cgi}{opt_protect_apache}) { + require GT::MD5::Crypt; + my $salt = join '', ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/')[map rand 64, 1 .. 8]; + $crypted = GT::MD5::Crypt::apache_md5_crypt($password, $salt); + } + else { + my @salt_chars = ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/'); + my $salt = join '', @salt_chars[rand 64, rand 64]; + $crypted = crypt($password, $salt); + } + push @users, "$username:$crypted\n"; + $message = $self->language('MSG_USER_ADDED', $username); + } + elsif ($self->{cgi}{protect} and !$del_user) { + return $self->print_json_error($self->language('ERR_PROTECT_REQUIRED')); + } + elsif ($del_user) { + $message = $self->language('MSG_USER_DELETED', $del_user); + } + + if (@users) { + open (HTPWD, "> $htpwd") or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $name_pwd, $!)); + print HTPWD join("", @users); + close HTPWD; + foreach (@users) { + my ($u, $p) = split(/:/, $_); + } + } + else { + unlink $htpwd; + unlink $htacc; + } + return $self->print_json(undef, 1, $message); +} +END_OF_SUB + +$COMPILE{setup} = __LINE__ . <<'END_OF_SUB'; +sub setup { +# ----------------------------------------------------------------------------- +# Change configurations +# + my $self = shift; + + return $self->print_json({ html => $self->print('setup.html', { json => 1 }) }, 1) if $self->{cgi}{form}; + + my %required_fields = (cgi_url => 1, static_url => 1, root_path => 1); + foreach (keys %required_fields) { + return $self->print_json_error($self->language('MSG_REQUIRED', $_)) unless $self->{cgi}{$_}; + } + + if ($self->{cfg}{fversion} eq 'multiple') { + return $self->print_json_error($self->language('ERR_MAIL_SERVER')) unless $self->{cgi}{email_smtp_server} or $self->{cgi}{email_mail_path}; + return $self->print_json_error($self->language('ERR_INVALID_MAIL')) if $self->{cgi}{email_smtp_server} and $self->{cgi}{email_mail_path}; + } + + my $config = $self->{cfg}; + foreach my $k (keys %$config) { + if (ref $config->{$k} eq 'HASH') { + my $hsh = $config->{$k}; + $config->{$k} = $self->fsetup($hsh, $k); + } + elsif (!defined $self->{in}->param($k)) { + next; + } + else { + $config->{$k} = $self->{in}->param($k); + } + } + +# Overwrite current configurations + $self->{cfg} = $config; + $self->{cfg}->save(); + +# Log the action + $self->flog("setup|Change the configuration"); + $self->print_json(undef, 1, $self->language('MSG_CHANCES_SAVED')); +} + +sub fsetup { +# ----------------------------------------------------------------------------- +# + my ($self, $cfg, $key) = @_; + + foreach my $k (keys %$cfg) { + my $val = $cfg->{$k}; + if (ref $val eq 'HASH') { + $cfg->{$k} = $self->fsetup($val, "${key}_$k"); + } + elsif (defined $self->{in}->param("${key}_$k")) { + $cfg->{$k} = $self->{in}->param("${key}_$k") || ''; + } + } + return $cfg; +} + +END_OF_SUB + +$COMPILE{preferences} = __LINE__ . <<'END_OF_SUB'; +sub preferences { +# ----------------------------------------------------------------------------- +# Update preferences +# + my $self = shift; + + return $self->print_json({ html => $self->print('preferences.html', { json => 1 }) }, 1) if $self->{cgi}{form}; + + my ($pwd_path, $default_path) = ('', ''); + if ($self->{cgi}{pwd_path}) { + my $path = $self->check_path($self->{cgi}{pwd_path}); + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $self->{cgi}{pwd_path})) unless $path->{exist}; + return $self->print_json_error($self->lanugage('ERR_NOT_FOLDER', $self->{cgi}{pwd_path})) unless $path->{isdir}; + $pwd_path = $path->{full_path}; + } + + if ($self->{cgi}{path}) { + my $path = $self->check_path($self->{cgi}{path}); + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $self->{cgi}{path})) unless $path->{exist}; + return $self->print_json_error($self->language('ERR_NOT_FOLDER', $self->{cgi}{path})) unless $path->{isdir}; + $default_path = $path->{full_path}; + } + + my %defaults = ( + pwd_path => $pwd_path, + path => $default_path, + maxhits => $self->{cgi}{maxhits} || 25, + sb => $self->{cgi}{sb} || 'name', + so => $self->{cgi}{so} || 'asc', + readme => $self->{cgi}{readme} || 1, + show_hidden => $self->{cgi}{show_hidden} || 0, + editor_mode => $self->{cgi}{editor_mode} || 0, + effect => $self->{cgi}{effect} || 1 + ); + my $defaults = join ';', map "$_=$defaults{$_}" , (keys %defaults); + + print $self->{in}->header( + -cookie => [ + $self->{in}->cookie(-name => 'fileman_defaults', -value => $defaults, -expires => '+5y') + ] + ); + + $self->{default} = $self->default(%defaults); + $self->print_json({ defaults => $self->{default} }, 1, $self->language('MSG_CHANCES_SAVED')); +} +END_OF_SUB + +$COMPILE{download} = __LINE__ . <<'END_OF_SUB'; +sub download { +# ----------------------------------------------------------------------------- +# Download command +# + my $self = shift; + + my @files = $self->{in}->param('cinput'); + my $opt_zip = $self->{cgi}{download_compress}; + my $opt_mode = $self->{cgi}{download_mode}; + + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files; + +# Download a single file + if (scalar @files == 1 and !$opt_zip) { + my $file = $self->check_name($files[0]); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOT_READABLE', $file->{name})) unless $file->{read}; + + if ($file->{isfile}) { + $self->flog("download|$file->{name}"); + return $self->print_json({ file => $file, mode => $opt_mode }, 1); + } + else { + $opt_zip = 1; + } + } + +# Download multiple files + require GT::TempFile; + my $tempfile = new GT::TempFile(tmp_dir => $self->{cfg}{tmp_path}); + my $ext = 'tar'; + + if ($opt_zip == 3 and $GT::FileMan::HAVE_AZIP) { + $ext = 'zip'; + $self->create_zip(\@files, "$$tempfile.$ext"); + } + else { + $ext = ($opt_zip == 2 and $GT::FileMan::HAVE_GZIP) ? 'tar.gz' : 'tar'; + $self->create_tar(\@files, "$$tempfile.$ext"); + } + + $self->flog("download|$$tempfile.$ext"); + my $filename = "$$tempfile.$ext"; + $filename =~ s,^$self->{cfg}{tmp_path}/,,; + + return $self->print_json({ + file => { + name => $filename, + source => $ext, + mode => 'binary' + }, + }, 1); +} +END_OF_SUB + +$COMPILE{cmdcopy} = __LINE__ . <<'END_OF_SUB'; +sub cmdcopy { +# ----------------------------------------------------------------------------- +# Copy command +# + my ($self, $action, $to) = @_; + + $to ||= $self->{cgi}{copy_input}; + my @files = $self->{in}->param('cinput'); + my $copied = $self->{cgi}{num_done} || 0; + + return $self->print_json_error($self->language('ERR_INVALID_PATH')) unless $to; + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files or $self->{cgi}{'confirm-name'}; + + my $path = $self->check_path($to); + return $self->print_json_error($path->{error}) if $path->{error}; + + if ($path->{exist}) { + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $to)) unless $path->{write}; + } + else { + my ($fname) = $path->{full_path} =~ /\/([^\/]+)$/; + (my $path_to = $path->{full_path}) =~ s/\/$fname$//; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $to)) unless -e $path_to; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $to)) unless -w $path_to; + } + + if ($self->{diskspace} and !$action) { # check free space if appicable + my $need_space = $self->size(\@files); + return $self->print_json_error($self->language('ERR_NOSPACE')) unless ($self->{diskspace}{free} or $self->{diskspace}{free} > $need_space); + } + + # Need a confirmation on overwrite existing files + my @loop_files; + if ($self->{cgi}{'confirm-name'}) { + return $self->print_json(undef, 1, $self->language('MSG_COPIED', $copied, $to)) if $self->{cgi}{'button-cancel'}; + + if ($self->{cgi}{'confirm-name'} eq 'copy-all') { + foreach my $f (@files) { + next unless $f; + my $file = $self->check_name($f); + next if $file->{error}; + + if ($action eq 'move') { + move($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + else { + copy($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + } + } + elsif ($self->{cgi}{'confirm-name'} !~ /button-cancel|button-skip/) { + my $fcurrent = $self->{cgi}{'confirm-name'}; + my $file = $self->check_name($fcurrent); + unless ($file->{error}) { + if ($action eq 'move') { + move($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + else { + copy($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + } + + foreach my $f (@files) { + next unless $f and $f ne $fcurrent; + push @loop_files, $f; + } + } + } + else { + foreach my $f (@files) { + my $file = $self->check_name($f); + next if $file->{error} or $file->{full_path} eq $path->{full_path}; + + if (-e "$path->{full_path}/$f") { + push @loop_files, $f; + next; + } + + if ($action eq 'move') { + move($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + else { + copy($file->{full_path}, $path->{full_path}, { untaint => 1 }) and $copied++; + } + } + } + +# Need confirmation on overwrite existing files + return $self->print_json({ confirms => \@loop_files, num_done => $copied, input => $to }, 1) if scalar @loop_files; + + my $history = $action eq 'move' ? "move" : "copy"; + my $msg = $action eq 'move' ? $self->language('MSG_MOVED', $copied, $to) : $self->language('MSG_COPIED', $copied, $to); + $self->flog("$history|To: $path->{full_path} ($copied files)"); + return $self->print_json(undef, 1, $msg); +} +END_OF_SUB + +$COMPILE{cmdmove} = __LINE__ . <<'END_OF_SUB'; +sub cmdmove { +# ----------------------------------------------------------------------------- +# Move command +# + my $self = shift; + return $self->cmdcopy('move', $self->{cgi}{'move_input'}); +} +END_OF_SUB + +$COMPILE{rename} = __LINE__ . <<'END_OF_SUB'; +sub rename { +# ----------------------------------------------------------------------------- +# Rename command +# + my $self = shift; + + my $to = $self->{cgi}{rename_input}; + my $f = $self->{cgi}{cinput}; + + return $self->print_json_error($self->language('ERR_RENAME_INPUT')) unless $to; + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless $f; + return $self->print_json_error($self->language('ERR_CANNOT_RENAME', $to)) if $to =~ /\//; + return $self->print_json_error($self->language('ERR_MULT_SELECTED')) if ref $f eq 'ARRAY'; + + my $path = $self->check_path($to); + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json({ file => { name => $to }, confirm => 1 }, 1) if $path->{exist} and !$self->{cgi}{overwrite_confirmed}; + + my ($fname) = $path->{full_path} =~ /\/([^\/]+)$/; + (my $path_to = $path->{full_path}) =~ s/\/$fname$//; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $to)) unless -e $path_to; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $self->{cfg}{work_path})) unless -w $path_to; + + my $file = $self->check_name($f); + return $self->print_json_error($file->{error}) if $file->{error}; + + move($file->{full_path}, $path->{full_path}, { untaint => 1 }); + + $self->flog("Rename|From: $f - To:$fname"); + $self->print_json(undef, 1, $self->language('MSG_RENAMED', $f, $fname)); +} +END_OF_SUB + +$COMPILE{delete} = __LINE__ . <<'END_OF_SUB'; +sub delete { +# ----------------------------------------------------------------------------- +# Delete files & directories +# + my $self = shift; + + my @files = $self->{in}->param('cinput'); + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files or $self->{cgi}{'confirm-name'}; + + + my $num_done = $self->{cgi}{num_done} || 0; + my $confirmed = $self->{cgi}{'confirm-name'} || ''; + + my (@deleted, @loop_files); + foreach my $f (@files) { + my $file = $self->check_name($f); + next if $file->{error} or !$file->{exist}; + + # Delete confirmed files and folders + if ($confirmed eq 'delete-all' or $confirmed eq $f) { + my $deleted = 0; + if ($file->{isfile}) { + del($file->{full_path}, { untaint => 1 }) and $deleted = 1; + } + else { + deldir($file->{full_path}, { untaint => 1 }) and $deleted = 1; + } + if ($deleted) { + $num_done++; + push @deleted, $file->{full_path}; + } + } + elsif (!$confirmed or $confirmed !~ /button-skip|button-cancel/) { + push @loop_files, $f; + } + } + +# Log deleted files + $self->flog("delete|".join("; ", @deleted)) if scalar @deleted; + +# Need to confirm on deleting selected files + return $self->print_json({ confirms => \@loop_files, num_done => $num_done }, 1) if scalar @loop_files; + return $self->print_json(undef, 1, $self->language($num_done > 1 ? 'MSG_MULT_DELETED' : 'MSG_DELETED', $num_done)); +} +END_OF_SUB + +$COMPILE{symlink} = __LINE__ . <<'END_OF_SUB'; +sub symlink { +# ----------------------------------------------------------------------------- +# Symlink command +# + my $self = shift; + + my @files = $self->{in}->param('cinput'); + my $to = $self->{cgi}{symlink_input}; + return $self->print_json_error($self->language('ERR_SYMLINK_INPUT')) unless $to; + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files; + + my $path = $self->check_path($to); + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $to)) unless $path->{exist}; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $to)) unless $path->{write}; + + my $links = 0; + foreach my $f (@files) { + my $file = $self->check_name($f, 1); + next if $file->{error} or $file->{full_path} eq $path->{full_path}; + +# Untaint the path + my $p = "$path->{full_path}/$f"; + ($p) = $p =~ /^(.*)$/; + symlink($file->{full_path}, $p) and $links++; + } + + return $self->print_json(undef, 1, $self->language('MSG_LINKED', $links, $to)); +} +END_OF_SUB + +$COMPILE{compress} = __LINE__ . <<'END_OF_SUB'; +sub compress { +# ----------------------------------------------------------------------------- +# Compress files and directories +# + my $self = shift; + + my @files = $self->{in}->param('cinput'); + my $loc = $self->{cgi}{compress_input}; + my $mode = $self->{cgi}{compress_mode} || 1; + + return $self->print_json_error($self->language('ERR_GZIP_REQUIRED')) if $mode == 2 and !$GT::FileMan::HAVE_GZIP; + return $self->print_json_error($self->language('ERR_AZIP_REQUIRED')) if $mode == 3 and !$GT::FileMan::HAVE_AZIP; + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless scalar @files; + +# Verify file name as well as location to store the compressed file + my $fname; + unless ($loc) { + my $path = $self->check_path(undef); + return $self->print_json_error($path->{error}) if $path->{error}; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $path->{full_path})) unless $path->{write}; + return $self->print_json_error($self->language('ERR_COMPRESS_INPUT')) if scalar @files > 1; + + ($fname) = $files[0] =~ /([^.]+)/; + return $self->print_json_error($self->language('ERR_COMPRESS_INPUT')) unless $fname; + } + elsif ($loc =~ /\/$/) { + return $self->print_json_error($self->language('ERR_COMPRESS_INPUT')) if scalar @files > 1; + + ($fname) = $files[0] =~ /([^.]+)/; + return $self->print_json_error($self->language('ERR_COMPRESS_INPUT')) unless $fname; + $fname = "$loc$fname"; + } + else { + $fname = $loc; + } + +# Handling compressed file extension + ($fname) = $fname =~ /([^.]+)/; + if ($mode > 1) { + $fname .= $mode == 2 ? '.tar.gz' : '.zip'; + } + else { + $fname .= '.tar'; + } + + my $file = $self->check_name($fname); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOSPACE')) if $self->{diskspace} and !$self->{diskspace}{free}; + return $self->print_json_error($self->language('ERR_FILENAME_EXISTING')) if scalar @files == 1 and $files[0] eq $fname; + + return $self->print_json_error({ file => $file, confirm => 1 }) if $file->{exist} and !$self->{cgi}{overwrite_confirmed}; + + if ($mode == 3) { + $self->create_zip(\@files, $file->{full_path}); + } + else { + $self->create_tar(\@files, $file->{full_path}); + } + + if ($self->{diskspace} and $self->{diskspace}{free} < -s $file->{full_path}) { + unlink $file->{full_path}; + return $self->print_json_error('nospace'); + } + + $self->flog("compress|$file->{name}"); + + return $self->print_json(undef, 1, $self->language('MSG_COMPRESSED', $file->{name})); +} +END_OF_SUB + +$COMPILE{uncompress} = __LINE__ . <<'END_OF_SUB'; +sub uncompress { +# ----------------------------------------------------------------------------- +# uncompress a file +# + my $self = shift; + + my @files = $self->{in}->param('compress'); + my $to = $self->{cgi}{uncompress_input}; + my $scope = $self->{cgi}{uncompress_scope}; + my $fname = $self->{cgi}{compressed_file}; + + my $file = $self->check_name($fname); + my $path = $self->check_path($to); + + return $self->print_json_error($file->{error} || $path->{error}) if $file->{error} or $path->{error}; + return $self->print_json_error($self->language('ERR_NOSELECTED')) if $scope and !scalar @files; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $fname)) unless $file->{exist}; + return $self->print_json_error($self->language('ERR_NOT_READABLE', $fname)) unless $file->{read}; + return $self->print_json_error($self->language('ERR_NOT_WRITABLE', $to)) if $path->{exist} and !$path->{write}; + return $self->print_json_error($self->language('ERR_NOSPACE')) if ($self->{diskspace} and !$self->{diskspace}{free}); + +# Untaint the path + ($path->{full_path}) = $path->{full_path} =~ /^(.*)$/; + +# Create the target folder if it does not exist + unless ($path->{exist}) { + rmkdir($path->{full_path}, 0755, { untaint => 1 }) or return $self->print_json_error($self->language('ERR_MAKEDIR', $to, $!)); + } + + my ($copied, $total_size, $hits) = (0, 0, 0); + my %error; + if ($file->{full_path} =~ /.zip$/i) { + require Archive::Zip; + my $zip = Archive::Zip->new($file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $fname, $!)); + my @members = $zip->members(); + $hits = scalar @members; + foreach my $f (@members) { + last if ($self->{diskspace} and $total_size + $f->uncompressedSize > $self->{diskspace}{free}); + my $name = $f->fileName; + my $found = ($scope and scalar @files) ? 0 : 1; + if ($scope) { + foreach (@files) { + next if $_ ne $name; + $found = 1; + last; + } + } + next unless $found; + + $copied++; + $total_size += $f->uncompressedSize; + + # Untaint file name + ($name) = $name =~ /^(.*)$/; + $zip->extractMember($name, "$path->{full_path}/$name"); + } + } + else { + require GT::Tar; + my $tar = GT::Tar->open($file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $fname, $GT::Tar::error)); + my $cfiles = $tar->files; + $hits = scalar @$cfiles; + + foreach my $f (@$cfiles) { + last if ($self->{diskspace} and $total_size + $f->{size} > $self->{diskspace}{free}); + my $name = $f->{name}; + my $found = ($scope and scalar @files) ? 0 : 1; + if ($scope) { + foreach (@files) { + next if $_ ne $name; + $found = 1; + last; + } + } + next unless $found; + $total_size += $f->{size}; + $copied++; + $f->write($path->{full_path}, { untaint => 1 }); + } + } + + $self->flog("cmd_uncompress|$fname"); + $self->print_json(undef, 1, $self->language('MSG_UNCOMPRESSED', $fname, $hits, $copied)); +} +END_OF_SUB + +$COMPILE{tail} = __LINE__ . <<'END_OF_SUB'; +sub tail { +# ----------------------------------------------------------------------------- +# tail command +# + my $self = shift; + + my $lines = $self->{cgi}{tail_input} || 25; + my $retime = $self->{cgi}{tail_retime}; + my $fname = $self->{cgi}{cinput}; + + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless $fname; + return $self->print_json_error($self->language('ERR_MULT_SELECTED')) if ref $fname eq 'ARRAY'; + + my $file = $self->check_name($fname); + return $self->print_json_error($file->{error}) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOTTEXT_FILE', $fname)) unless $file->{isfile} and $file->{text}; + return $self->print_json_error($self->language('ERR_READABLE', $fname)) unless $file->{read}; + return $self->print_json_error($self->language('ERR_EMPTY_FILE', $fname)) unless $file->{size}; + + my ($follow, $buffer, $content); + @ARGV = grep { if ($_ eq "-f") { $follow++; 0 } else { 1 } } @ARGV; + open DATA, "<$file->{full_path}" or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $fname, $!)); + + my $read_size = $file->{size} > $READ_SIZE ? $READ_SIZE : $file->{size}; + seek DATA, -$read_size, 2; + read DATA, $buffer, $read_size; + my $read = $read_size; + $lines--; + + while () { + if ($buffer =~ /\n(.*(?:\n.*){$lines}\n?$)/) { + $content .= $1; + last; + } + $read_size = ($file->{size} - $read > $READ_SIZE) ? $READ_SIZE : $file->{size} - $read; + unless ($read_size == 0) { + $content .= $buffer; + last; + } + seek DATA, -($read_size + $read), 2; + $read += $read_size; + my $new_buffer; + my $bytes_read = read DATA, $new_buffer, $read_size; + if ($bytes_read == 0) { + $content .= $buffer; + last; + } + $buffer = $new_buffer . $buffer; + } + + my $count = 0; + if ($follow) { + seek DATA, 0, 2; # Seek to the end of the file + while () { + select undef, undef, undef, 1; + seek DATA, 0, 1 or last; # Reset eof(FILE) + print while ; + seek DATA, 0, 2; + last if ($count++ > 60); # Only run for one min max. + } + } + $self->print_json({ output => $self->{in}->html_escape($content), refresh => $retime }, 1); +} +END_OF_SUB + +$COMPILE{perl} = __LINE__ . <<'END_OF_SUB'; +sub perl { +# ----------------------------------------------------------------------------- +# Perl command +# + my $self = shift; + + my @files = $self->{in}->param('cinput'); + return $self->print_json_error($self->language('ERR_PERL_SELECTED')) unless @files; + + $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; #for taint mode + + my @output; + foreach my $f (@files) { + my $file = $self->check_name($f); + if ($file->{error}) { + push @output, { name => $f, error => $file->{error} }; + next; + } + elsif (!$file->{read}) { + push @output, { name => $f, error => $self->language('ERR_NOT_READABLE', $file->{full_path}) }; + next; + } + elsif (!$file->{isfile} or !$file->{text}) { + push @output, { name => $f, error => $self->language('ERR_NOTPERL_FILE', $file->{full_path}) }; + next; + } + my ($ext) = $f =~ /\.([^.]+)$/; + if ($ext !~ /^(?:cgi|pl|pm)$/i) { push @output, { name => $f, error => $self->language('ERR_NOTPERL_FILE', $file->{full_path}) }; next; } + + my ($fname) = $file->{full_path} =~ /^$self->{cfg}{root_path}(.*)/; + my $result = fsystem($self->{cfg}{path_to_perl}, + '-cw -I', + "$self->{cfg}{private_path}/lib", + $file->{full_path}, + ); + push @output, { name => $f, %$result }; + } + $self->print_json({ files => \@output }, 1); +} +END_OF_SUB + +$COMPILE{diff} = __LINE__ . <<'END_OF_SUB'; +sub diff { +# ----------------------------------------------------------------------------- +# Diff Command +# + my $self = shift; + + my $fname1 = $self->{cgi}{cinput}; + my $fname2 = $self->{cgi}{diff_input}; + return $self->print_json_error($self->language('ERR_NOSELECTED')) unless $fname1; + return $self->print_json_error($self->language('ERR_DIFF_INPUT')) unless $fname2; + return $self->print_json_error($self->language('ERR_MULT_SELECTED')) if ref $fname1 eq 'ARRAY'; + + my $file1 = $self->check_name($fname1); + my $file2 = $self->check_name($fname2); + return $self->print_json_error($file1->{error} || $file2->{error}) if $file1->{error} or $file2->{error}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $fname1)) unless $file1->{exist}; + return $self->print_json_error($self->language('ERR_NOT_FOUND', $fname2)) unless $file2->{exist}; + return $self->print_json_error($self->language('ERR_NOTTEXT_FILE', $fname1)) unless $file1->{text}; + return $self->print_json_error($self->language('ERR_NOTTEXT_FILE', $fname2)) unless $file2->{text}; + + require GT::FileMan::Diff; + my $diff = GT::FileMan::Diff::html_diff($file1->{full_path}, $file2->{full_path}, 3); + return $self->print_json_error($self->language('ERR_CANNOT_OPEN', ($diff == 1 ? $fname1 : $fname2), $!)) unless ref $diff; + + $self->print_json({ output => $$diff }, 1); +} +END_OF_SUB + +$COMPILE{preview} = __LINE__ . <<'END_OF_SUB'; +sub preview { + my $self = shift; + + my $file = $self->check_name($self->{cgi}{f}); + return $self->print_json_error($self->language('ERR_INVALID_FILE')) if $file->{error}; + return $self->print_json_error($self->language('ERR_NOT_FILE', $file->{name})) unless $file->{isfile}; + return $self->print_json_error($self->language('ERR_NOT_READABLE', $file->{name})) unless $file->{read}; + + if ($file->{type} =~ /^(?:text|html)$/) { + open(TEXT, $file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + read TEXT, my $content, -s TEXT; + close TEXT; + + $file->{content} = $self->{in}->html_escape($content); + } + elsif ($file->{type} eq 'compress') { + return $self->open_compressed($file); + } + return $self->print_json({ file => $file }, 1); +} +END_OF_SUB + +$COMPILE{fdownload} = __LINE__ . <<'END_OF_SUB'; +sub fdownload { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $fname = $self->{cgi}{f}; + my $mode = $self->{cgi}{mode} || 'auto'; + + return if ref $fname eq 'ARRAY'; + + my $file; + if ($self->{cgi}{type}) { +# Untaint the path + my $full_path = "$self->{cfg}{tmp_path}/$fname"; + ($full_path) = $full_path =~ /^(.*)$/; + + $file = { + full_path => $full_path, + name => 'download.' . $self->{cgi}{type}, + size => -s $full_path + } + } + else { + $file = $self->check_name($fname); + return if $file->{error} or !$file->{isfile}; + } + + $mode = 'ascii' if ($mode and lc $mode eq 'auto' and $file->{text}); + open(DATA, $file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + if ($file->{name} =~ /.zip$/i) { + print $self->{in}->header( + '-type' => 'application/octect-stream', + '-Content-Length' => $file->{size}, + '-Content-Transfer-Encoding' => 'binary', + '-Content-Disposition' => \(qq/attachment; filename="$file->{name}"/ . (defined($file->{size}) ? "; size=$file->{size}" : '')) + ); + } + else { + print $self->{in}->header($self->{in}->file_headers( + filename => $file->{name}, + inline => 0, + size => $file->{size} + )); + } + + binmode STDOUT if $GT::FileMan::MSWIN; + binmode DATA; + + my $newlines = $GT::FileMan::MSWIN ? "\r\n" : "\n"; + my $buffer; + while (read(DATA, $buffer, $READ_SIZE)){ + $buffer =~ s,$newlines,\n,g if $mode eq 'ascii'; + print $buffer; + } + close DATA; +} +END_OF_SUB + +$COMPILE{env} = __LINE__ . <<'END_OF_SUB'; +sub env { +# ----------------------------------------------------------------------------- +# Print out environment +# + my $self = shift; + + my $env = GT::FileMan::base_env($self->{in}, $self->{cfg}{version}, $self->{commands}); + $self->print_json({ html => $self->print('env.html', { json => 1, env => \$env }) }, 1); +} +END_OF_SUB + +$COMPILE{login} = __LINE__ . <<'END_OF_SUB'; +sub login { +# ----------------------------------------------------------------------------- +# + my ($self, %args) = @_; + + return $self->print('home.html') unless $self->{cgi}{login}; + return $self->print_json_error($self->language('ERR_INVALID_LOGIN')) unless $self->{cgi}{username} and $self->{cgi}{password}; + return $self->print_json_error($self->language('ERR_INVALID_USERNAME')) if $self->{cfg}{login}{username} ne $self->{cgi}{username}; + return $self->print_json_error($self->language('ERR_INVALID_PASSWORD')) if $self->{cfg}{login}{password} ne GT::FileMan::encrypt($self->{cgi}{password}, $self->{cfg}{login}{password}) and $self->{cfg}{login}{password} ne crypt($self->{cgi}{password}, $self->{cfg}{login}{password}); + + my $session = $self->session_create($self->{cfg}{login}, $self->{cgi}{cookie}); + return $self->print_json_error($self->language('ERR_SESSION')) unless $session; + + my $user = $self->{cfg}{login}; + $user->{permission} = $self->{cfg}{permission}; + $self->{session} = { id => $session->{id}, user => $user }; + + $self->flog("login|$user->{username}"); + $self->print_json(undef, 1); +} +END_OF_SUB + +$COMPILE{logout} = __LINE__ . <<'END_OF_SUB'; +sub logout { +# ----------------------------------------------------------------------------- +# + my ($self, $error) = @_; + + $self->session_delete(); + $self->flog('logout|Logged out'); + + $self->{session} = undef; + my %args = ( json => 1 ); + if ($error) { + $args{error} = $error + } + else { + $args{message} = $self->language('MSG_LOGOUT'); + } + $self->print_json({ html => $self->print('login.html', \%args) }, 1, undef, 'LOGGED_OUT'); +} +END_OF_SUB + +$COMPILE{help} = __LINE__ . <<'END_OF_SUB'; +sub help { +# ----------------------------------------------------------------------------- +# + my $self = shift; + my $page = $self->{cgi}{page} || 'help.html'; + + $page = 'help.html' if $page ne 'help.html' and $page ne 'quicktip.html'; + ($page) = $page =~ /^(.*)$/; + + $self->print($page); +} +END_OF_SUB + +$COMPILE{cmdprint} = __LINE__ . <<'END_OF_SUB'; +sub cmdprint { +# ----------------------------------------------------------------------------- +# Print selected file(s) +# + my $self = shift; + + my @input = $self->{in}->param('cinput'); + +# Check the selected files + my @files; + foreach my $f (@input) { + my $file = $self->check_name($f); + next unless !$file->{error} and $file->{isfile} and $file->{text}; + + push @files, $file; + } + return $self->print_json_error($self->language('ERR_PRINT')) unless scalar @files; + return $self->print_json({ files => \@files }, 1) unless $self->{cgi}{print}; + + + my $output = qq~ + +
        Gossamer Threads - FileMan
        +~; + + if ($self->{cgi}{all}) { # Print multiple files + my $flag = 0; + foreach my $f (@files) { + open (DATA, "< $f->{full_path}") or next; + read (DATA, my $data, -s DATA); + close DATA; + + + my $style = $flag ? 'style="page-break-before: always;"' : ''; + $output .= qq|

        $data

        |; + $flag++; + } + } + else { # Print single file + my $file = pop @files; + my $next_url = ''; + if (scalar @files) { + my $hiddens = $self->hiddens(); + $next_url = $self->{in}->url(absolute => 1, query_string => 0) . "?cmd=print$hiddens->{hidden_query};print=1"; + foreach (@files) { + $next_url .= ";cinput=" . $self->{in}->escape($_->{name}); + } + } + open (DATA, "< $file->{full_path}") or return $self->home(error => $self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + read (DATA, my $data, -s DATA); + close DATA; + + $output .= qq|
        $data

        |; + $output = sprintf(qq|
        |, $next_url) . $output if $next_url; + } + $output .= qq!!; + + print $self->{in}->header; + print $output; +} +END_OF_SUB + +sub open_compressed { +# ----------------------------------------------------------------------------- +# Open a compressed file +# + my ($self, $file) = @_; + + my ($ext) = $file->{name} =~ /\.([^.]+)$/; + + my @files; + my $total_size = 0; + if (lc $ext eq 'zip') { + require Archive::Zip; + my $zip = new Archive::Zip($file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + foreach my $f ($zip->members) { + my $type = $f->isDirectory ? FOLDER : FILE; + my $name = $f->fileName; + my $spec = ficon($name, $type); + my $perm = $f->unixFileAttributes; + my $date = $f->lastModTime; + my $size = $f->compressedSize; + my @info = ( + $type, + $spec->{icon}, + $name, + $size, + $spec->{type}, + $date, + '', + $perm, + permission($perm), + GT::Date::date_get($date, $self->{cfg}{date_format} || '%yyyy%-%mm%-%dd%'), + ); + $total_size += $size; + push @files, \@info; + } + } + else { + require GT::Tar; + my $tar = GT::Tar->open($file->{full_path}) or return $self->print_json_error($self->language('ERR_CANNOT_OPEN', $file->{name}, $!)); + my $files = $tar->files; + foreach my $f (@$files) { + my $type = $f->{type} == 5 ? FOLDER : FILE; + my $spec = ficon($f->{name}, $type); + my $owner = (eval {getpwuid($f->{uid})} || '') . ':' . (eval {getgrgid($f->{gid})} || ''); + my @info = ( + $type, + $spec->{icon}, + $f->{name}, + $f->{size}, + $spec->{type}, + $f->{mtime}, + $owner, + $f->{mode}, + permission($f->{mode}), + GT::Date::date_get($f->{mtime}, $self->{cfg}{date_format} || '%yyyy%-%mm%-%dd%'), + ); + + $total_size += $f->{size}; + push @files, \@info; + } + } + + return $self->print_json({ html => $self->print('compressed.html', { file => $file, json => 1 }), files => \@files, compressed => 1 }, 1); +} + +sub create_zip { +# ----------------------------------------------------------------------------- +# + my ($self, $files, $to) = @_; + + require Archive::Zip::Tree; + my $zip = Archive::Zip->new(); + + foreach my $f (@$files) { + my $file = $self->check_name($f); + next unless !$file->{error} and $file->{read}; + +# Untaint the path + ($file->{full_path}) = $file->{full_path} =~ /^(.*)$/; + ($f) = $f =~ /^(.*)$/; + if (-d $file->{full_path}) { + my @files; + find($file->{full_path}, sub { + my $fp = shift; + my $fn = $fp; + $fn =~ s/$self->{cfg}{root_path}\///; + if (-d $fp) { + $zip->addDirectory($fp, $fn) or warn "$!"; + } + else { + $zip->addFile($fp, $fn) or warn "$!"; + } + }, { untaint => 1 }); + } + elsif ($file->{isfile}) { + $zip->addFile($file->{full_path}, $f) or warn "$!"; + } + } + my $error = $zip->writeToFileNamed($to) ? $! : ''; + return $self->home({ error => { cannot_zip => 1, message => $error }}) if $error; +} + +sub create_tar { +# ----------------------------------------------------------------------------- +# + my ($self, $files, $to) = @_; + + require GT::Tar; + my $fpath = $self->check_path(); + my $tar = new GT::Tar($to); + + my $from = $fpath->{error} ? '' : $fpath->{full_path}; + foreach my $f (@$files) { + my $file = $self->check_name($f); + next unless !$file->{error} and $file->{read}; + $tar->add_file($file->{full_path}); + } + + my $items = $tar->files; + foreach my $f (@$items) { + $f->{name} =~ s,$from/,,; + } + $tar->write($to); +} + +sub current_path { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $work_path = $self->{cfg}{work_path}; + return unless $work_path; + + my (@paths, $parent); + my $work_folders = [split /\//, $work_path]; + + my $spath = ''; + foreach my $f (@$work_folders) { + next unless $f; + push @paths, { folder => $f, path => $spath }; + $spath .= $spath ? "/$f" : $f; + + $parent = '/'; + foreach my $i (0..$#$work_folders - 1) { + $parent .= ($parent =~ /\/$/) ? $work_folders->[$i] : "/$work_folders->[$i]"; + } + } + return { parent => $parent, work_path => $work_path, loop => \@paths }; +} + +sub finfo { +# ----------------------------------------------------------------------------- +# Load file information +# + my ($self, $full_path, $fname) = @_; + + my $path = $self->check_path(); + my $work_path = $path->{error} ? '' : $path->{full_path}; + my ($located) = $full_path =~ /^$work_path\/(.*)/; + $located =~ s,/$fname$,,; + + my (@stat, $type, $link); + if (-l $full_path) { + @stat = lstat($full_path); + $type = -d $full_path ? FOLDER : FILE; + $link = readlink $full_path; + } + else { + @stat = stat($full_path); + $type = -d $full_path ? FOLDER : FILE; + } + + my $spec = ficon($full_path, $type); + my $owner = (eval {getpwuid($stat[4])} || '') . ':' . (eval {getgrgid($stat[5])} || ''); + my @info = ( + $type, + $link ? 'symlink' : $spec->{icon}, + $self->{in}->html_escape($fname), + $type == FOLDER ? 0 : $stat[7], + $link ? $ICONS{symlink}->[1] : $spec->{type}, + $stat[9], + $owner, + sprintf("%04o", ($stat[2] & 07777)), + permission($stat[2]), + GT::Date::date_get($stat[9], $self->{cfg}{date_format} || '%yyyy%-%mm%-%dd%'), + $located eq $fname ? '' : $located, + $link || $full_path, + ); + return \@info; +} + +sub friendly_size { +# ----------------------------------------------------------------------------- +# Prints out the file size. +# + my $size = shift; + return $size <= 100 + ? "$size Bytes" + : $size < 10 * KB + ? sprintf("%.2f ", $size / KB) . 'KB' + : $size < 100 * KB + ? sprintf("%.2f ", $size / KB) . 'KB' + : $size < MB + ? sprintf("%.2f ", $size / KB) . 'KB' + : $size < 10 * MB + ? sprintf("%.2f ", $size / MB) . 'MB' + : $size < 100 * MB + ? sprintf("%.2f ", $size / MB) . 'MB' + : sprintf("%.2f ", $size / MB) . 'MB'; +} + +sub permission { +# ----------------------------------------------------------------------------- +# Takes permissions supplied from stat() and prints out in ls -al format. +# + my $octal = shift; + + my $string = sprintf "%04o", ($octal & 07777); + my @perms = split '', $string; + + my $result = '--- --- ---'; + my @extra_map = ( + { mask => 0x4, char => 's' }, + { mask => 0x2, char => 's' }, + { mask => 0x1, char => 't' }, + ); + + for (my $i = 1; $i < @perms; $i++) { + my $j = $i - 1; + + substr($result, $j * 4 + 0, 1, 'r') if 0x4 & $perms[$i]; + substr($result, $j * 4 + 1, 1, 'w') if 0x2 & $perms[$i]; + +# The display of execute needs to be handled differently as it also shows the +# additional permissions + my $exec = 0x1 & $perms[$i]; + my $char; + $char = 'x' if $exec; + $char = $extra_map[$j]->{char} if $extra_map[$j]->{mask} & $perms[0]; + $char = uc $char if !$exec and $char ne 'x'; + substr($result, $j * 4 + 2, 1, $char) if $char; + } + return $result; +} + +sub ficon { +# ----------------------------------------------------------------------------- +# Get the associated icon based on a files extension +# + my ($file, $type) = @_; + + return { icon => $ICONS{folder}[0], type => $ICONS{folder}[1] } if $type == FOLDER; + + my ($ext) = $file =~ /\.([^.]+)$/; + return { icon => $ICONS{unknown}[0], type => $ICONS{unknown}[1] } unless $ext; + + foreach (keys %ICONS) { + next if $_ =~ /^(?:folder|unknown|parent)$/; + return { icon => $ICONS{$_}[0], type => $ICONS{$_}[1]} if $_ =~ /\b\Q$ext\E\b/i; + } + + return { icon => $ICONS{unknown}[0], type => $ICONS{unknown}[1] }; +} + +sub load_htpasswd { +# ----------------------------------------------------------------------------- +# Load .htpasswd +# + my $self = shift; + + my $pwd_path = $self->{default}{pwd_path}; + my $htpwd; + if ($pwd_path) { + my $path = $self->check_path($pwd_path); + if (!$path->{error} and $path->{exist}) { + my $current = $self->check_path(); + $current->{full_path} =~ s/[\/ \:]/\_/g; + $htpwd = "$path->{full_path}/.htpass$current->{full_path}"; + ($htpwd) = $htpwd =~ /^(.*)$/; # Untaint the path + } + } + + unless ($htpwd) { + my $fpassword = $self->check_name('.htpasswd'); + return if $fpassword->{error}; + $htpwd = $fpassword->{full_path}; + } + + my $faccess = $self->check_name(".htaccess"); + return unless !$faccess->{error} and $htpwd; + + my $htacs = $faccess->{full_path}; + if (-e $htpwd and $faccess->{exist}) { + my ($name_pwd) = $htpwd =~ /^$self->{cfg}{root_path}\/(.*)/; + open (HTPWD, "< $htpwd") or return; + my @users = map { /^([^:]+)/ ? qq:$1: : qq:'': } ; + close HTPWD; + return \@users; + } +} + +sub create_htaccess { +# ----------------------------------------------------------------------------- +# Creates the htaccess file. +# + my ($self, $htaccess, $htpasswd) = @_; + + my $raq = $ENV{GT_COBALT_RAQ} ? "AuthPAM_Enabled off\n" : ''; + open (HTAC, "> $htaccess") or return "open_file: $htaccess - $!"; + print HTAC <$to") or return 0; + open(SOURCE, "<$from") or return 0; + binmode SOURCE; + binmode TARGET; + + my ($buffer, $bit); + while (my $rs = read SOURCE, $buffer, $READ_SIZE) { + if ($replace) { + $buffer = "$bit$buffer" if length $bit; + $bit = ($rs == $READ_SIZE and $buffer =~ s/(?:\r|\r?\n)([^\r\n]+)$//) ? $1 : ''; + + $buffer =~ s/$replace/$with/g; + } + print TARGET $buffer; + } + close SOURCE; + close TARGET; + fchmod($from, $to); + return 1; +} + +sub fchmod { +# ----------------------------------------------------------------------------- +# set chmod +# + my($from, $to) = @_; + $from =~ m,^([/\w.-]+)$,; + $from = $1; + + $to =~ m,^([/\w.-]+)$,; + $to = $1; + + my $stat = [stat($from)]; + chmod(@$stat[2], $to); +} + +sub size { +# ----------------------------------------------------------------------------- +# Load size of files and directories +# + my ($self, $files) = @_; + + my $total_size = 0; + + foreach my $f (@$files) { + next unless $f; + my $file = $self->check_name($f); + next if $f->{error}; + if ($file->{isfile}) { + $total_size += $file->{size}; + } + else { + find($file->{full_path}, sub { $total_size += -s shift }, { untaint => 1 }); + } + } + return $total_size; +} + +sub check_path { +# ----------------------------------------------------------------------------- +# Check a directory make sure it safe +# It returns a full path or a hash +# + my ($self, $dir) = @_; + + my $root = $self->{cfg}{root_path}; + my $work = $self->{cfg}{work_path}; + $work =~ s/^\/// if $work; + + my $full_path; + unless ($dir) { + $full_path = $work ? "$root/$work" : $root; + } + elsif ($dir eq '/') { + $full_path = $root; + } + else { + $full_path = $dir =~ m,^/, ? "$root$dir" : "$root/". ($work ? "$work/" : "") . "$dir"; + } + +# Untaint the path + ($full_path) = $full_path =~ /^(.*)$/; + + if (-e $full_path) { + my $current_path = cwd(); + chdir($full_path); + + $full_path = cwd(); + +# Untaint the path + ($current_path) = $current_path =~ /^(.*)$/; + chdir($current_path); + + if ($full_path =~ /^$root(.*)$/) { + $work = $1; + } + else { + return { error => $self->language('ERR_OUT_BOUNCE', $dir) }; + } + } + + return { error => $self->language('ERR_INVALID_INPUT', $full_path) } if ($self->{cfg}{filename_check} and $full_path !~ m,^([-\w/. ]+)$,); + + return { + work_path => $work, + full_path => $full_path, + exist => -e $full_path, + isdir => -d $full_path, + write => -w $full_path, + read => -r $full_path + }; +} + +sub check_name { +# ----------------------------------------------------------------------------- +# Check a file/directory name make sure +# - Not contain an special characters if the option is on +# - Not out side root directory +# + + my ($self, $file) = @_; + + my ($fname, $fpath); + if ($file =~ /^(.*)\/([^\/]+)$/) { + $fpath = $1; + $fname = $2; + } + else { + $fname = $file; + } + return { error => $self->language('ERR_INVALID_INPUT') } unless $fname; + + my $path = $self->check_path($fpath); + return { error => $path->{error} } if $path->{error}; + + return { error => $self->language('ERR_INVALID_INPUT') } if $self->{cfg}{filename_check} and $fname !~ m,^([-\w/. ]+)$,; + + my $full_path = $path->{full_path} . '/' . $fname; + +# Untaint the path + ($full_path) = $full_path =~ /^(.*)$/; + + my ($ext) = $fname =~ /\.([^.]+)$/; + my $type; + if ($ext =~ /^(?:bmp|gif|jpg|tif|tiff|ico|png)$/i) { + $type = 'image'; + } + elsif (-T $full_path and $ext =~ /^(?:html|htm|shtml|shtm)$/i) { + $type = 'html'; + } + elsif (-T $full_path and lc $ext ne 'pdf') { # Open a text file e.g: *.txt, *.html, ect... + $type = 'text'; + } + elsif ($ext =~ /^(?:doc|xls|pdf|mp3|mpga|mpg)$/i) { + $type = 'doc'; + } + elsif ($ext =~ /^(?:tar|gz|zip)$/i) { + $type = 'compress'; + } + else { + $type = 'unknown'; + } + + return { + name => $file, + type => $type, + full_path => $full_path, + exist => -e $full_path, + write => -w $full_path, + read => -R $full_path, + text => ($ext !~ /^(?:pdf|doc|xls)$/ and -T $full_path), + size => -s $full_path, + isfile => -f $full_path, + }; +} + +sub flog { +# ----------------------------------------------------------------------------- +# + my ($self, $log) = @_; + return unless $self->{cfg}{fversion} eq 'multiple'; + + $self->history($log); +} + +sub upload_progress { +# Upload progress +# It returns a json object with all progess numbers +# + my $self = shift; + + my ($serial) = $self->{cgi}{upload}; + +# Untaint the path + my $logfile = "$self->{cfg}{tmp_path}/$serial"; + ($logfile) = $logfile =~ /^(.*)$/; + return $self->print_json_error(undef) unless -e $logfile; + + my ($progress, $currentfile, $totalprogress, $totalsize, $end_time, $start_time, $elapsedtime, $filename, $allowed_space, $free_space) = (); + + open(READLOGFILE,"< $logfile") or return $self->print_json_error(undef); + flock READLOGFILE, 1; + seek READLOGFILE, 0, 0; + my $line = ; + chomp $line; + close READLOGFILE or return $self->print_json_error(undef); + unlink $logfile; + + ($progress, $totalsize, $start_time, $end_time, $filename, $allowed_space, $free_space) = split(/:\|:/, $line); + $self->print_json({ + uploaded => $progress, + upload_size => $totalsize, + elapsed_time => $end_time - $start_time, + allowed_space => $allowed_space, + free_space => $free_space, + filename => $filename, + }, 1); +} + +sub fsystem { + my (@args) = @_; + + my ($output, $error) = ('', ''); + my $tmp_output = new GT::TempFile; + my $tmp_errors = new GT::TempFile; + + open(OLDOUT, ">&STDOUT"); + open(OLDERR, ">&STDERR"); + open(STDOUT, ">$$tmp_output") or return { error => "Can't redirect STDOUT" }; + open(STDERR, ">$$tmp_errors") or return { error => "Can't redirect STDERR" }; + + select(STDERR); + $| = 1; + select(STDOUT); + $| = 1; + + my $snum = system(@args); + +# Close and restore STDOUT and STDERR + close STDOUT; + close STDERR; + open(STDOUT, ">&OLDOUT"); + open(STDERR, ">&OLDERR"); + + open (TMP, "< $$tmp_output") or return { error => $! }; + read (TMP, $output, -s TMP); + close TMP; + open (TMP, "< $$tmp_errors") or return { error => $! }; + read (TMP, $error, -s TMP); + close TMP; + + unlink $$tmp_output; + unlink $$tmp_errors; + + return $snum ? { error => $output || $error } : { message => $output || $error }; +} +1 diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands/Language.pm b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands/Language.pm new file mode 100644 index 0000000..dad2003 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands/Language.pm @@ -0,0 +1,145 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::FileMan::Commands::Language +# Author: Jason Rhinelander +# CVS Info : 087,068,085,094,083 +# $Id: Language.pm,v 1.4 2006/02/11 04:54:51 jagerman Exp $ +# +# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# Language variables for GT::FileMan::Commands +# + +package GT::FileMan::Commands::Language; +use strict; +use Exporter(); +use vars qw/@EXPORT @ISA %LANGUAGE/; +@EXPORT = qw/%LANGUAGE/; +@ISA = qw/Exporter/; + +my $download_suffix = '%s (%s bytes) -
        Download'; + +%LANGUAGE = ( + UPLOAD_MODE => "File %s was successfully uploaded in %s mode.", + MSG_LOG_OFF => "Please enter username and password to login.", + MSG_MULTI_UPLOAD => "%s files have been successfully uploaded.", + MSG_CHMOD_CHANGED => "Permissions on %s file(s) have been updated successfully.", + MSG_SEACH_FOUND => "Your search found %s results.", + MSG_REPLA_FOUND => "Your search and replace updated %s files in %s", + MSG_SEACH_NOTFOUND => "Your search did not produce any results.", + MSG_FILE_EDITING => "Editing $download_suffix", + MSG_FILE_VIEWING => "Viewing $download_suffix", + MSG_FILE_CONTENTS => "Viewing contents of $download_suffix", + MSG_FILE_CREATED => "%s has been created.", + MSG_FILE_EDITED => "Changes to %s have been saved.", + MSG_DIR_CREATED => "%s directory has been created.", + MSG_PREFERENCES => "Your options have been saved.", + MSG_UNCOMPRESS => "%s file has been unarchived.", + MSG_TAR_CANCEL => "Creation of tar file has been cancelled.", + MSG_TAR_CREATED => "Tar file %s has been created.", + MSG_COPIED => " %s selected file/directory(s) have been copied (%s can not be copied).", + MSG_MOVED => " %s selected file/directory(s) have been moved (%s can not be moved).", + MSG_DEL_SUCC => "%s files and %s directories have been removed.", + MSG_DEL_CURR => "You've removed the directory: %s", + MSG_DEL_ALL => "You've removed the directory, and all contents recursively.", + MSG_DEL_SKIP => "You've skipped the directory: %s", + MSG_DEL_CANC => "You've cancelled deleting the directory", + MSG_DEL_ALL_SUCC => "All child dirs and files on the selected directorys has been removed. ", + MSG_CONTINUE => " click here to continue.", + MSG_PWD_CHANGED => "Your password was changed. ", + MSG_DEMO => "Disabled in Demo.", + MSG_USER_ADDED => "%s was added successfully.", + MSG_USER_DELETED => "%s was deleted successfully.", + MSG_USER_RMALL => "Users were deleted sucessfully.", + ERR_DEL => "Can not remove file(s)", + ERR_CHMOD => "Can not change mode ", + ERR_FILE_OPEN => "Can not open file: %s", + ERR_FILE_EMPTY => "File %s is empty.", + ERR_FILE_EXISTS => "File %s exists.", + ERR_FILE_NOT_EXISTS => "File %s does not exist.", + ERR_FILE_PERM => " Sorry, but we don't have write access to the htaccess files: '%s' and '%s'", + ERR_FILE_PEM => "The %s directory is not writeable.", + ERR_NOT_TEXT_FILE => "File %s is not a text file.", + ERR_DIR_NOT_EXISTS => "Directory %s does not exist.", + ERR_DIR_PEM => "The %s is not writeable.", + ERR_DIR_PERM => "Please check permission.", + ERR_NOT_ISFILE => "%s is a directory.", + ERR_TMP_FILE => "Can not open temp file.", + ERR_FREE_SPC => "Upload: Not enough free space to upload that file.", + ERR_RM_FILE => "Unable to remove file: %s. Reason: %s", + ERR_UPLOAD => "Unable to upload file: %s. Reason: %s.", + ERR_FILE_SAVE => "Cannot save file %s. Check permissions.", + ERR_DIR_EXISTS => "Directory %s already exists.", + ERR_NAME => "Illegal Characters in Directory. Please use letters, numbers, - and _ only.", + ERR_FILE_NAME1 => "No double .. allowed in file names.", + ERR_FILE_NAME2 => "No leading . in file names.", + ERR_READ_DIR => "Can not open dir: %s. Reason: %s", + ERR_DIR_DEEP => "Directory level too deep.", + ERR_DISK_SPACE => "Not enough space to save it (free space is %s kb)", + ERR_UNCOMPRESS => "Select files or directories before to uncompress.", + ERR_TAR => "Error: %s.", + ERR_TAR_NOT_EXISTS => "Can not create a tar file: %s", + ERR_TAR_PEM => "Can not create a tar file %s. Check permission.", + ERR_DOWNLOAD => "You selected a directory !", + ERR_LOGIN => "Invalid Username and Password.", + ERR_INVALID => "Input value has invalid characters : %s ", + ERR_NOT_FILE => "The %s is not a file", + ERR_OLD_PASSWORD => "Invalid Old password", + ERR_NEW_PASSWORD => "New password must be more than 3 character", + ERR_OPEN_FILE => "Can not open %s file, reason: %s", + ERR_WRITEABLE => "Can not save %s file, reason: %s", + ERR_NO_AZIP => "Please install the Archive::Zip library which is required.", + ERR_NO_GZIP => "Please install the Compress::Zlib library which is required.", + COBALT_NOREMOTE => "FileMan is not currently running under server authentication!", + ERR_VERSION => "This action does not support for your current version!", + ERR_PRINT => "Please select the files which are required text or image files", + PRINT_NEXT => "Print Next", + COBALT_NOUSER => "Unable to lookup user '%s'", + COBALT_BADUID => "Invalid user '%s' (%s)", + COBALT_CANTSU => "Can't switch to user '%s' (%s,%s). Reason: '%s'", + COBALT_BADDIR => "Invalid home directory '%s'. It does not look like a standard Raq director.", + COBALT_BADGROUP => "This program is restricted to site administrators only. You must be in the site administer group in order to use this.", + FILETYPE_IMAGE => 'Image file', + FILETYPE_TEXT => 'Text file', + FILETYPE_SCRIPT => 'Script file', + FILETYPE_COMPRESSED => 'Compressed file', + FILETYPE_HTML => 'HTML file', + FILETYPE_SOUND => 'Audio file', + FILETYPE_BINARY => 'Binary file', + FILETYPE_DOC => 'MS Word', + FILETYPE_XLS => 'MS Excel', + FILETYPE_PDF => 'PDF file', + FILETYPE_FOLDER => 'File Folder', + FILETYPE_UNKNOWN => 'Unknown file', + FILETYPE_EXT => '%s file', + FILECOL_NAME => 'Name', + FILECOL_SIZE => 'Size', + FILECOL_DATE => 'Modified', + FILECOL_PERM => 'Permissions', + FILECOL_USER => 'Owner', + FILECOL_TYPE => 'File Type', + FILECOL_VIEW => 'View', + DATE_SHORT_JAN => 'Jan', + DATE_SHORT_FEB => 'Feb', + DATE_SHORT_MAR => 'Mar', + DATE_SHORT_APR => 'Apr', + DATE_SHORT_MAY => 'May', + DATE_SHORT_JUN => 'Jun', + DATE_SHORT_JUL => 'Jul', + DATE_SHORT_AUG => 'Aug', + DATE_SHORT_SEP => 'Sep', + DATE_SHORT_OCT => 'Oct', + DATE_SHORT_NOV => 'Nov', + DATE_SHORT_DEC => 'Dec', + DIR_PARENT => 'Parent Directory', + README => 'Readme File', + COMMAND_TIMEOUT => 'Command timed out', + COMMAND_KILLFAIL => 'Unable to kill process (%s): %s', + EXTRACT_FILE_OK => '%s... okay', + EXTRACT_FILE_SKIP => '%s... skipped', +); + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Diff.pm b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Diff.pm new file mode 100644 index 0000000..e264da1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Diff.pm @@ -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 : 087,071,086,086,085 +# 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
        ...
        . 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||; + $colors{"${_}_close"} = qq||; + } + else { + $colors{$_} = qq||; + $colors{"${_}_close"} = qq||; + } + } + + 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) = '
        ';
        +    $$ret .= '
        '; + + $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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Session.pm b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Session.pm new file mode 100644 index 0000000..29052d4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Session.pm @@ -0,0 +1,103 @@ +# ================================================================== +# File manager - enhanced web based file management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Session.pm,v 1.1 2007/12/19 23:32:47 bao 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::Session; + +use strict; +use GT::Session::File; + +sub session_valid { +# This function checks to see if the session is valid, and returns a +# hash of session information +# + my $self = shift; + + my $session_path = "$self->{cfg}->{private_path}/sessions"; + +# Clear out old sessions. + GT::Session::File->cleanup($self->{cfg}->{session}->{expiry} * 3600, $session_path); + +# Validate the session + my $session_id = $self->{in}->param('sid') || $self->{in}->cookie($self->{cfg}->{session}->{cookie}) || return; + my $session = new GT::Session::File ( + directory => $session_path, + id => $session_id + ) || return; + +# Update the session + $session->save; + + return { id => $session_id, data => $session->{data} }; +} + +sub session_create { + my ($self, $user, $use_cookie) = @_; + + my $session_path = "$self->{cfg}->{private_path}/sessions"; + +# Clear out old sessions. + GT::Session::File->cleanup($self->{cfg}->{session}->{expiry} * 3600, $session_path); + +# Create a new session and save the information. + my $session = new GT::Session::File (directory => $session_path); + $session->{data}->{user} = $user->{username}; + $session->save; + +# Now redirect to another URL and set cookies, or set URL string. + if ($use_cookie) { + print $self->{in}->cookie( + -name => $self->{cfg}->{session}->{cookie}, + -value => $session->{id}, + -path => '/' + )->cookie_header() . "\n"; + } + else { + $self->{cgi}->{sid} = $session->{id}; + } + return { id => $session->{id}, data => $session->{data} }; +} + +sub session_delete { + my $self = shift; + + print $self->{in}->cookie( + -name => $self->{cfg}->{session}->{cookie}, + -value => '', + -path => '/' + )->cookie_header() . "\n"; + + my $session_id = $self->{in}->cookie($self->{cfg}->{session}->{cookie}) || $self->{in}->param('sid') || return; + my $session = new GT::Session::File ( + directory => "$self->{cfg}->{private_path}/sessions", + id => $session_id + ) || return; + return $session->delete(); +} + +sub session_save { + my ($self, $id, $args) = @_; + + return unless $id and $args; + + my $session_path = "$self->{cfg}->{private_path}/sessions"; + my $session = new GT::Session::File ( + directory => $session_path, + id => $id + ); + + foreach (keys %$args) { + next unless $args->{$_}; + $session->{data}->{$_} = $args->{$_}; + } + $session->save(); +} +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm new file mode 100644 index 0000000..cb74380 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm @@ -0,0 +1,107 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Filter +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Does nothing for now, here as a referance. +# + +package GT::IPC::Filter; +# ================================================================== + +die "Do not use me"; + +1; + +__END__ + +=head1 SYNOPSIS + + use GT::IPC::Filter::Foo; + + my $filter = new GT::IPC::Filter::Foo(sub { my $out = shift ... }); + # -or- + my $filter = new GT::IPC::Filter::Foo( + output => sub { my $out = shift; .. }, + %options + ); + + $filter->put(\$data); + + $filter->flush; + +=head1 DESCRIPTION + +This documents how to create a filter. The filter system documented here is +used for GT::IPC::Run, L, currently but could be useful for other +things relating to IO and IPC. + +=head1 METHODS + +You will need to impliment three methods to create a filter. These methods are +pretty simple and strait forward. + +=head2 new + +This is your constructor. You will need to return an object. You should be able +to take a sigle argument as well as a hash of options. It isn't manditory but +it will keep the filter interface consistent. + +The one argument form of C is a code reference. This code reference will +be called with the data (in whatever form) after you filter it. You should +default the rest of your arguments to something reasonable. If there are no +reasonable defaults for your options you can stray from this and require the +hash form, but you should have a nice error for people that call you with the +one argument form: + + $class->fatal( + BADARGS => "This class does not accept the one argument form for filters" + ) if @_ == 1; + +The hash form should take a key C which will be the code reference +output will go to once you filter it. The rest of the keys are up to you. Try +to have reasonable defaults for the other keys, but fatal if there are any that +are required and not present. + +=head2 put + +This method is called with a scaler reference of the data you will be +filtering. You are expect to make changes to the data and call the C +code reference with the formatted data. For example GT::IPC::Filter::Line +calles the C code reference with each line of data, see +L. It is ok if you change the scalar reference passed +into you. + +=head2 flush + +C if called when the stream of data is at an end. Not arguments are +passed to it. You are expected send any data you are buffering to the C +code reference at this point, after filtering it if nessisary. + +=head1 SEE ALSO + +See L, L, L, +and L. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $ + +=cut + + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm new file mode 100644 index 0000000..97c1cf9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm @@ -0,0 +1,154 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Filter::Block +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Filter streams of input out in block sizes. +# + +package GT::IPC::Filter::Block; +# ================================================================== + +use strict; +use base 'GT::Base'; + +sub new { +# ---------------------------------------------------------------------------- + my $class = shift; + + if (@_ == 1) { + @_ = (output => $_[0]); + } + $class->fatal(BADARGS => "Arguments to new() must be a hash") + if @_ & 1; + my %opts = @_; + + my $output = delete $opts{output}; + $class->fatal(BADARGS => "No output for new()") + unless defined $output; + $class->fatal(BADARGS => "No output passed to new() is not a code ref") + unless ref($output) eq 'CODE'; + + my $block_size = delete $opts{block_size}; + $block_size = 512 unless defined $block_size; + + return bless { + block_size => $block_size, + output => $output, + }, $class; +} + +sub put { +# ---------------------------------------------------------------------------- + my ($self, $in) = @_; + + if (defined $self->{buffer}) { + $$in = $self->{buffer} . $$in; + undef $self->{buffer}; + } + if (length($$in) >= $self->{block_size}) { + my $gets = int(length($$in) / $self->{block_size}); + for (1 .. $gets) { + $self->{output}->(substr($$in, 0, $self->{block_size})); + substr($$in, 0, $self->{block_size}) = ''; + } + } + $self->{buffer} = $$in; +} + +sub flush { +# ---------------------------------------------------------------------------- + my ($self) = @_; + $self->{output}->($self->{buffer}) if defined $self->{buffer}; + undef $self->{buffer}; +} + +1; + +__END__ + +=head1 NAME + +GT::IPC::Filter::Block - Implements block based filtering for output streams. + +=head1 SYNOPSIS + + use GT::IPC::Filter::Block; + + my $filter = new GT::IPC::Filter::Block( + sub { my $block = shift ... } + ); + # -or- + my $filter = new GT::IPC::Filter::Block( + output => sub { my $out = shift; .. }, + block_size => 512 # Default + ); + + $filter->put(\$data); + + $filter->flush; + +=head1 DESCRIPTION + +Implements block based filtering to an output code reference. Used mainly in +GT::IPC::Run, L for details. + +=head1 METHODS + +There are three methods (as with all filters in this class). + +=head2 new + +Takes either a single argument, which is a code reference to call output with, +or a hash of options. + +=over 4 + +=item output + +This is the code reference you would like called with each block of output. +The blocks are stripped of there ending before this is called. + +=item block_size + +This is the size of chunks of data you want your code reference called with. It +defaults to 512. + +=back + +=head2 put + +This method takes a stream of data, it converted it into block based data using +the C you specified and passes each block to the code reference +specified by C, see L<"new">. There is buffering that happens here. + +=head2 flush + +This method should be called last, when the data stream is over. It flushes the +remaining buffer out to the code reference. + +=head1 SEE ALSO + +See L. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm new file mode 100644 index 0000000..33048e5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm @@ -0,0 +1,176 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Filter::Line +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Filter streams of input out to a line. +# + +package GT::IPC::Filter::Line; +# ================================================================== + +use strict; +use base 'GT::Base'; + +sub new { +# ---------------------------------------------------------------------------- + my $class = shift; + + if (@_ == 1) { + @_ = (output => $_[0]); + } + $class->fatal(BADARGS => "Arguments to new() must be a hash") + if @_ & 1; + my %opts = @_; + + my $output = delete $opts{output}; + $class->fatal(BADARGS => "No output for new()") + unless defined $output; + $class->fatal(BADARGS => "No output passed to new() is not a code ref") + unless ref($output) eq 'CODE'; + + my $regex = delete $opts{regex}; + my $literal = delete $opts{literal}; + + $class->fatal(BADARGS => "You can only specify one of literal and regex") + if defined $regex and defined $literal; + + if (defined $literal) { + $regex = quotemeta $literal; + } + + if (!defined $regex) { + $regex = '\x0D\x0A?|\x0A\x0D?'; + } + + return bless { + regex => $regex, + output => $output, + }, $class; +} + +sub put { +# ---------------------------------------------------------------------------- + my ($self, $in) = @_; + + if (defined $self->{buffer}) { + $$in = $self->{buffer} . $$in; + undef $self->{buffer}; + } + my $regex = $self->{regex}; + my @in = split /($regex)/ => $$in; + + # Not a complete line + if ($in[$#in] !~ /$regex/) { + $self->{buffer} = pop @in; + } + + for (my $i = 0; $i < $#in; $i += 2) { + $self->{output}->($in[$i]); + } +} + +sub flush { +# ---------------------------------------------------------------------------- + my ($self) = @_; + $self->{output}->($self->{buffer}) if defined $self->{buffer}; + undef $self->{buffer}; +} + +1; + +__END__ + +=head1 NAME + +GT::IPC::Filter::Line - Implements line based filtering for output streams. + +=head1 SYNOPSIS + + use GT::IPC::Filter::Line; + + my $filter = new GT::IPC::Filter::Line( + sub { my $line = shift ... } + ); + # -or- + my $filter = new GT::IPC::Filter::Line( + output => sub { my $out = shift; .. }, + regex => '\r?\n' + ); + + $filter->put(\$data); + + $filter->flush; + +=head1 DESCRIPTION + +Implements line based filtering to an output code reference. Used mainly in +GT::IPC::Run, L for details. + +=head1 METHODS + +There are three methods (as with all filters in this class). + +=head2 new + +Takes either a single argument, which is a code reference to call output with, +or a hash of options. + +=over 4 + +=item output + +This is the code reference you would like called with each line of output. The +lines are stripped of there ending before this is called. + +=item regex + +Specify the regex to use in order to determine the end of line sequence. This +regex is used in a split on the input stream. If you capture in this regex it +will break the output. + +=item literal + +Specifies a literal new line sequence. The only difference between this option +and the C option is it is C, See L. + +=back + +=head2 put + +This method takes a stream of data, it converted it into line based data and +passes each line to the code reference specified by C, see L<"new">. +There is buffering that happens here because we have no way of knowing if the +output stream does not end with a new line, also streams almost always get +partial lines. + +=head2 flush + +This method should be called last, when the data stream is over. It flushes the +remaining buffer out to the code reference. + +=head1 SEE ALSO + +See L. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm new file mode 100644 index 0000000..0275e47 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm @@ -0,0 +1,127 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Filter::Stream +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Filter streams of input out to a streams ;). +# + +package GT::IPC::Filter::Stream; +# ================================================================== + +use strict; +use base 'GT::Base'; + +sub new { +# ---------------------------------------------------------------------------- + my $class = shift; + + if (@_ == 1) { + @_ = (output => $_[0]); + } + $class->fatal(BADARGS => "Arguments to new() must be a hash") + if @_ & 1; + my %opts = @_; + + my $output = delete $opts{output}; + $class->fatal(BADARGS => "No output for new()") + unless defined $output; + $class->fatal(BADARGS => "No output passed to new() is not a code ref") + unless ref($output) eq 'CODE'; + + return bless { output => $output }, $class; +} + +sub put { +# ---------------------------------------------------------------------------- + my ($self, $in) = @_; + + $self->{output}->($$in); +} + +sub flush { +# ---------------------------------------------------------------------------- +# Does nothing +} + +1; + +__END__ + +=head1 NAME + +GT::IPC::Filter::Block - Implements stream based filtering for output streams. + +=head1 SYNOPSIS + + use GT::IPC::Filter::Stream; + + my $filter = new GT::IPC::Filter::Block( + sub { my $chunk = shift ... } + ); + # -or- + my $filter = new GT::IPC::Filter::Block( + output => sub { my $chunk = shift; .. }, + ); + + $filter->put(\$data); + + $filter->flush; + +=head1 DESCRIPTION + +Implements stream based filtering to an output code reference. Used mainly in +GT::IPC::Run, L for details. Basically just a pass through to +your code reference. + +=head1 METHODS + +There are three methods (as with all filters in this class). + +=head2 new + +Takes either a single argument, which is a code reference to call output with, +or a hash of options. + +=over 4 + +=item output + +This is the code reference you would like called with each output. + +=back + +=head2 put + +This method takes a stream of data and passed it strait to your code reference. +There is no buffering that happens here. + +=head2 flush + +This method does nothing. + +=head1 SEE ALSO + +See L. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run.pm new file mode 100644 index 0000000..efe6212 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run.pm @@ -0,0 +1,873 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Run +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Runs programs or code references in parallel +# +package GT::IPC::Run; + +use strict; +use base 'GT::Base'; +use vars qw/@EXPORT_OK $SYSTEM $DEBUG $ERRORS/; + +use Exporter(); +use Socket; +use Symbol qw/gensym/; +use POSIX qw(fcntl_h errno_h :sys_wait_h); + +use GT::IPC::Filter::Line; +use GT::IPC::Run::Select; +use GT::IPC::Run::Child; + +my $can_run_socket = undef; + +*import = \&Exporter::import; +@EXPORT_OK = qw/run/; +$DEBUG = 0; + +sub READ_BLOCK () { 512 } +sub IS_WIN32 () { $^O eq 'MSWin32' } + +$ERRORS = { + SEMAPHORE => "Could not create semephore socket; Reason: %s", + FORK => "Could not fork; Reason: %s" +}; + +BEGIN { + # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp + # defines EINPROGRESS as 10035. We provide it here because some + # Win32 users report POSIX::EINPROGRESS is not vendor-supported. + if (IS_WIN32) { + eval '*EINPROGRESS = sub { 10036 };'; + eval '*EWOULDBLOCK = sub { 10035 };'; + eval '*F_GETFL = sub { 0 };'; + eval '*F_SETFL = sub { 0 };'; + require GT::IPC::Run::Win32; + import GT::IPC::Run::Win32; + $SYSTEM = 'GT::IPC::Run::Win32'; + } + else { + require GT::IPC::Run::Unix; + import GT::IPC::Run::Unix; + $SYSTEM = 'GT::IPC::Run::Unix'; + } +} + +sub new { +# ------------------------------------------------------------------------ + my $self = bless {}, $SYSTEM; + $self->{select} = new GT::IPC::Run::Select; + return $self; +} + +sub run { +# ------------------------------------------------------------------------ + my ($program, $out, $err, $in) = @_; + my $self = new GT::IPC::Run; + my $ref; + + $self->fatal("No program specified to start") + unless defined $program; + $ref = ref $program; + $self->fatal("Invalid program passed to start $program") + if + $ref ne 'CODE' and + $ref ne 'ARRAY' and + $ref; + + $ref = defined($out) ? ref($out) : undef; + my $out_is_handle = _is_handle($out); + $self->fatal( + BADARGS => "stdout handler is not a code ref or scalar ref" + ) if + defined $ref and + $ref ne 'CODE' and + $ref ne 'SCALAR' and + !$out_is_handle and + $ref !~ /\AGT::IPC::Filter::/; + + $ref = defined($err) ? ref($err) : undef; + my $err_is_handle = _is_handle($err); + $self->fatal( + BADARGS => "stderr handler is not a code ref or scalar ref" + ) if + defined $ref and + $ref ne 'CODE' and + $ref ne 'SCALAR' and + !$err_is_handle and + $ref !~ /\AGT::IPC::Filter::/; + + $ref = ref $in; + my $in_is_handle = _is_handle($in); + $self->fatal( + BADARGS => "stdin handler is not a scalar ref or filehandle" + ) if + $ref ne 'SCALAR' and + !$in_is_handle and + $ref !~ /\AGT::IPC::Filter::/ and + defined $in; + + my $pid = $self->start( + program => $program, + stdout => $out, + stderr => $err, + stdin => $in, + debug => $DEBUG + ); + 1 while $self->do_one_loop; + my $exit_code = $self->exit_code($pid); + return $exit_code; +} + +sub start { +# ------------------------------------------------------------------------ + my $self = shift; + $self->fatal(BADARGS => "Arguments to start() must be a hash") + if @_ & 1; + my %opts = @_; + my $ref; + + $self->{_debug} = delete $opts{debug}; + $self->{_debug} = $DEBUG unless defined $self->{_debug}; + + my $program = delete $opts{program}; + $self->fatal("No program specified to start") + unless defined $program; + $ref = ref $program; + $self->fatal("Invalid program passed to start $program") + if + $ref ne 'CODE' and + $ref ne 'ARRAY' and + $ref; + + my $out = delete $opts{stdout}; + my $actual_out; + $ref = defined($out) ? ref($out) : undef; + my $out_is_handle = _is_handle($out); + + # Default to line filter for stderr + if ($ref and $ref eq 'CODE') { + $actual_out = new GT::IPC::Filter::Line($out); + } + elsif ($ref and $ref eq 'SCALAR') { + $actual_out = new GT::IPC::Filter::Line(sub { $$out .= "$_[0]\n" }); + } + elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) { + $actual_out = $out; + } + elsif (defined($out) and !$out_is_handle) { + $self->fatal( + BADARGS => "stdout handler is not a code ref or scalar ref" + ); + } + + my $err = delete $opts{stderr}; + my $actual_err; + my $err_is_handle = _is_handle($err); + $ref = defined($err) ? ref($err) : undef; + + # Default to line filter for stderr + if ($ref and $ref eq 'CODE') { + $actual_err = new GT::IPC::Filter::Line($err); + } + elsif ($ref and $ref eq 'SCALAR') { + $actual_err = new GT::IPC::Filter::Line(sub { $$err .= "$_[0]\n" }); + } + elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) { + $actual_err = $err; + } + elsif (defined($err) and !$err_is_handle) { + $self->fatal( + BADARGS => "stderr handler is not a code ref or scalar ref" + ); + } + + my $in = delete $opts{stdin}; + my $in_is_handle = _is_handle($in); + $ref = ref $in; + $self->fatal( + BADARGS => "stdin handler is not a scalar ref or filehandle" + ) if + $ref ne 'SCALAR' and + !$in_is_handle and + defined $in; + + + my $exit_callback = delete $opts{reaper}; + $self->fatal( + BADARGS => "The exit callback specified is not a code reference" + ) if + defined $exit_callback and + ref($exit_callback) ne 'CODE'; + + my $done_callback = delete $opts{done_callback}; + $self->fatal( + BADARGS => "The done callback specified is not a code reference" + ) if + defined $done_callback and + ref($done_callback) ne 'CODE'; + + $self->fatal( + BADARGS => "Unknown arguments ", join(", ", keys %opts) + ) if keys %opts; + + # get the sockets we need for stdin/stdout/stderr communication + my ($stderr_read, $stderr_write) = $self->oneway; + $self->fatal("could not make stderr pipe: $!") + unless defined $stderr_read and defined $stderr_write; + my ($stdout_read, $stdout_write) = $self->twoway; + $self->fatal("could not make stdout pipe: $!") + unless defined $stdout_read and defined $stdout_write; + my ($stdin_read, $stdin_write) = $self->oneway; + $self->fatal("could not make stdin pipes: $!") + unless defined $stdin_read and defined $stdin_write; + + # Defaults to blocking + $self->stop_blocking($stdout_read); + $self->stop_blocking($stdout_write); + $self->stop_blocking($stderr_read); + $self->stop_blocking($stderr_write); + + # Change the ones they have overridden + if ($in_is_handle) { + $stdin_read = $in; + undef $stdin_write; + undef $in; + } + elsif (!$in) { + undef $stdin_write; + undef $stdin_read; + } + if ($out_is_handle) { + $stdout_write = $out; + undef $stdout_read; + undef $out; + } + elsif (!$out) { + undef $stdout_write; + undef $stdout_read; + } + if ($err_is_handle) { + $stderr_write = $err; + undef $stderr_read; + } + elsif (!$err) { + undef $stderr_write; + undef $stderr_read; + } + + # Temporary location for these + $self->{current_child} = new GT::IPC::Run::Child( + program => $program, + stderr_read => $stderr_read, + stderr_write => $stderr_write, + stdout_read => $stdout_read, + stdout_write => $stdout_write, + stdin_write => $stdin_write, + stdin_read => $stdin_read, + stdin => $in, + handler_stdout => $actual_out, + handler_stderr => $actual_err, + exit_callback => $exit_callback, + done_callback => $done_callback, + exit_status => 0, + pid => 0 + ); + + # Run the program/code ref + my $pid = $self->execute; + return $pid; +} + +sub do_loop { +# ---------------------------------------------------------------------------- + my ($self, $wait) = @_; + 1 while $self->do_one_loop($wait); +} + +sub exit_code { +# ---------------------------------------------------------------------------- + my ($self, $pid) = @_; + $self->fatal( BADARGS => "No pid passed to exit_code" ) + unless defined $pid; + return $self->{goners}{$pid}; +} + +sub twoway { +# ------------------------------------------------------------------------ + my ( $self, $conduit_type ) = @_; + + # Try UNIX-domain socketpair if no preferred conduit type is + # specified, or if the specified conduit type is 'socketpair'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'socketpair' + ) and + not defined $can_run_socket + ) + { + my ($rw1, $rw2) = (gensym, gensym); + + eval { + socketpair( $rw1, $rw2, AF_UNIX, SOCK_STREAM, PF_UNSPEC ) + or die "socketpair 1 failed: $!"; + }; + + # Socketpair succeeded. + if ( !length $@ ) { + + $self->debug("Using socketpair for twoway") if $self->{_debug}; + # It's two-way, so each reader is also a writer. + + select( ( select($rw1), $| = 1 )[0] ); + select( ( select($rw2), $| = 1 )[0] ); + return ( $rw1, $rw2, $rw1, $rw2 ); + } + elsif ($DEBUG) { + $self->debug("Error with socketpair: $@\n"); + } + } + + # Try the pipe if no preferred conduit type is specified, or if the + # specified conduit type is 'pipe'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'pipe' + ) and + not defined $can_run_socket + ) + { + my ($read1, $write1, $read2, $write2) = + (gensym, gensym, gensym, gensym); + + eval { + pipe($read1, $write1) or die "pipe 1 failed: $!"; + pipe($read2, $write2) or die "pipe 2 failed: $!"; + }; + + # Pipe succeeded. + if (!length $@) { + + $self->debug("Using pipe for twoway") if $self->{_debug}; + # Turn off buffering. POE::Kernel does this for us, but someone + # might want to use the pipe class elsewhere. + select((select($write1), $| = 1)[0]); + select((select($write2), $| = 1)[0]); + return($read1, $write1, $read2, $write2); + } + elsif ($self->{_debug}) { + $self->debug("Error with pipe(): $@"); + } + } + + # Try a pair of plain INET sockets if no preffered conduit type is + # specified, or if the specified conduit type is 'inet'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'inet' + ) and ( + $can_run_socket or + not defined $can_run_socket + ) + ) + { + my ($rw1, $rw2) = (gensym, gensym); + + # Try using a pair of plain INET domain sockets. + eval { ($rw1, $rw2) = $self->make_socket }; # make_socket + # returns em + # non-blocking + + # Sockets worked. + if (!length $@) { + + $self->debug("Using inet socket for twoway") if $self->{_debug}; + # Try sockets more often. + $can_run_socket = 1; + + # Turn off buffering. POE::Kernel does this for us, but someone + # might want to use the pipe class elsewhere. + select((select($rw1), $| = 1)[0]); + select((select($rw2), $| = 1)[0]); + + return($rw1, $rw2, $rw1, $rw2); + } + elsif ($self->{_debug}) { + $self->debug("Error with socket: $@"); + } + + # Sockets failed. Don't dry them again. + } + $self->debug("Nothing worked") if $self->{_debug}; + + # There's nothing left to try. + return(undef, undef, undef, undef); +} + +sub oneway { +# ------------------------------------------------------------------------ + my ( $self, $conduit_type ) = @_; + + # Generate symbols to be used as filehandles for the pipe's ends. + my $read = gensym; + my $write = gensym; + + # Try UNIX-domain socketpair if no preferred conduit type is + # specified, or if the specified conduit type is 'socketpair'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'socketpair' + ) and + not defined $can_run_socket + ) + { + + eval { + socketpair($read, $write, AF_UNIX, SOCK_STREAM, PF_UNSPEC) + or die "socketpair failed: $!"; + }; + + # Socketpair succeeded. + if (!length $@) { + + $self->debug("Using socketpair for oneway") if $self->{_debug}; + # It's one-way, so shut down the unused directions. + shutdown($read, 1); + shutdown($write, 0); + + # Turn off buffering. POE::Kernel does this for us, but someone + # might want to use the pipe class elsewhere. + select((select($write), $| = 1)[0]); + return($read, $write); + } + elsif ($self->{_debug}) { + $self->debug("Could not make socketpair: $@"); + } + } + + # Try the pipe if no preferred conduit type is specified, or if the + # specified conduit type is 'pipe'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'pipe' + ) and + not defined $can_run_socket + ) + { + + eval { pipe($read, $write) or die "pipe failed: $!" }; + + # Pipe succeeded. + if (!length $@) { + + $self->debug("Using pipe for oneway") if $self->{_debug}; + # Turn off buffering. POE::Kernel does this for us, but + # someone might want to use the pipe class elsewhere. + select((select($write),$| = 1 )[0]); + return($read, $write); + } + elsif ($self->{_debug}) { + $self->debug("Could not make pipe: $@"); + } + } + + # Try a pair of plain INET sockets if no preffered conduit type is + # specified, or if the specified conduit type is 'inet'. + if ( + ( + not defined $conduit_type or + $conduit_type eq 'inet' + ) and ( + $can_run_socket or + not defined $can_run_socket + ) + ) + { + + # Try using a pair of plain INET domain sockets. + eval { ($read, $write) = $self->make_socket }; + + if (!length $@) { + + $self->debug("Using inet socket for oneway") if $self->{_debug}; + # Try sockets more often. + $can_run_socket = 1; + + # It's one-way, so shut down the unused directions. + shutdown($read, 1); + shutdown($write, 0); + + # Turn off buffering. POE::Kernel does this for us, but someone + # might want to use the pipe class elsewhere. + select((select($write), $| = 1)[0]); + return($read, $write); + } + else { + $self->debug("Could not make socket: $@") if $self->{_debug}; + $can_run_socket = 0; + } + } + $self->debug("Nothing worked") if $self->{_debug}; + return(undef, undef); +} + + +# Make a socket. This is a homebrew socketpair() for systems that +# don't support it. The things I must do to make Windows happy. + +sub make_socket { +# ------------------------------------------------------------------------ + my ($self) = @_; + + ### Server side. + + my $acceptor = gensym(); + my $accepted = gensym(); + + my $tcp = getprotobyname('tcp') or die "getprotobyname: $!"; + socket( $acceptor, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!"; + + setsockopt($acceptor, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "reuse: $!"; + + my $server_addr = inet_aton('127.0.0.1') or die "inet_aton: $!"; + $server_addr = pack_sockaddr_in( 0, $server_addr ) or die "sockaddr_in: $!"; + + bind($acceptor, $server_addr) or die "bind: $!"; + + $self->stop_blocking($acceptor); + + $server_addr = getsockname($acceptor); + + listen($acceptor, SOMAXCONN) or die "listen: $!"; + + ### Client side. + + my $connector = gensym(); + + socket($connector, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!"; + + $self->stop_blocking($connector); + + unless (connect( $connector, $server_addr)) { + die "connect: $!" + if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK); + } + + my $connector_address = getsockname($connector); + my ( $connector_port, $connector_addr ) = + unpack_sockaddr_in($connector_address); + + ### Loop around 'til it's all done. I thought I was done writing + ### select loops. Damnit. + + my $in_read = ''; + my $in_write = ''; + + vec($in_read, fileno($acceptor), 1) = 1; + vec($in_write, fileno($connector), 1) = 1; + + my $done = 0; + while ( $done != 0x11 ) { + my $hits = + select( my $out_read = $in_read, my $out_write = $in_write, undef, + 5 ); + + # For some reason this always dies when called + # successivly (quickly) on the 5th or 6th call + die "select: $^E" if $hits < 0; + #next unless $hits; + # try again? + # return $self->make_socket unless $hits; + + # Accept happened. + if ( vec( $out_read, fileno($acceptor), 1 ) ) { + my $peer = accept( $accepted, $acceptor ) or die "accept: $!"; + my ( $peer_port, $peer_addr ) = unpack_sockaddr_in($peer); + + if ( $peer_port == $connector_port + and $peer_addr eq $connector_addr ) + { + vec( $in_read, fileno($acceptor), 1 ) = 0; + $done |= 0x10; + } + } + + # Connect happened. + if ( vec( $out_write, fileno($connector), 1 ) ) { + $! = unpack( 'i', getsockopt( $connector, SOL_SOCKET, SO_ERROR ) ); + die "connect: $!" if $!; + + vec( $in_read, fileno($acceptor), 1 ) = 0; + $done |= 0x01; + } + } + + # Turn blocking back on, damnit. + $self->start_blocking($accepted); + $self->start_blocking($connector); + + return ( $accepted, $connector ); +} + +sub _is_handle { + my $ref = ref($_[0]); + return ( + ($ref and $ref eq 'GLOB') or + ($ref and $_[0] =~ /=GLOB\(/) + ); +} + +1; + +__END__ + +=head1 NAME + +GT::IPC::Run - Run programs or code in parallel + +=head1 SYNOPSIS + + use GT::IPC::Run; + + # stderr and stdout filters default to a + # GT::IPC::Line::Filter + my $exit_code = run + '/bin/ls', # Program to run + \*stdout_handle, # stdout event + \&stderr_handler, # stderr event + \$stdin; # stdin + + + my $io = new GT::IPC::Run; + + use GT::IPC::Filter::Line; + + my $pid = $io->start( + stdout => GT::IPC::Filter::Line->new( + regex => "\r?\n", + output => sub { print "Output: $_[0]\n" } + ), + program => sub { print "I got forked\n" }, + ); + + while ($io->do_one_loop) { + if (defined(my $exit = $io->exit_code($pid))) { + print "$pid exited ", ($exit>>8), "\n"; + } + } + +=head1 DESCRIPTION + +Module to simplify running a program or code reference in parallel. Allows +catching and filtering the output of the program and filtering it. + +=head1 FUNCTIONS + +GT::IPC::Run will import one function C if you request it to. + +=head2 run + +Run is a simple interface to running a program or a subroutine in a separate +process and catching the output, both stderr and stdout. This function takes +four arguments, only the first argument is required. + +=over 4 + +=item First Argument + +The first argument to C is the program to run or the code reference to +run. This argument can be one of three things. + +If a code reference if passed as the first argument to C, GT::IPC::Run +will fork off and run the code reference. You SHOULD NOT exit in the code +reference if you want your code to work on Windows. Calling C is ok, +as your code is evaled. There are some things you CAN NOT do if you want your +code to work on Windows. + +You SHOULD NOT make any calles to C or C. For some reason, on +Windows, this breaks filehandle inheritance so all your output from that moment +on (including the C or C) call will go to the real output +channel, STDERR or STDOUT. + +You SHOULD NOT change STDERR or STDOUT. The child process on Windows can +affect the filehandles in the parent. This is probably because of the way +C on Windows is emulated as threads. + +You probably should not C either, though this is not confirmed I +really doubt it will work the way you plan. + +If an array reference is passed in it will be dereferenced and passed to +C. If a scalar is passed in it will be passed to C. + +On Windows the arguments are passed to Win32::Process::Create as the program +you wish to run. See L. + +=item Second Argument + +The second argument to C is what you want to happen to STDOUT as it +comes in. This argument can be one of three things. + +If it is a reference to a GT::IPC::Filter:: class, that will be used to call +your code. See L for details. + +If it is a code reference, a new GT::IPC::Filter::Line object will be created +and your code reference will be passed in. Exactly: + + $out = GT::IPC::Filter::Line->new($out); + +GT::IPC::Filter::Line will call your code reference for each line of output +from the program, the end of the line will be stripped. See +L for details. + +If the argument is a scalar reference, again, a new GT::IPC::Filter::Line +object will be created. Exactly: + + + $out = GT::IPC::Filter::Line->new(sub { $$out .= $_[0] }); + + +=item Third Argument + +The third argument to L is used to handle STDERR if and when what you +are running produces it. + +This can be the exact same thing as the second argument, but will work on +STDERR. + +=item Forth Argument + +This argument is how to handle STDIN. It may be one of two things. + +If it is a SCALAR, it will be printed to the input of what you are running. + +=back + +=head1 METHODS + +=head2 new + +The is a simple method that takes no arguments and returns a GT::IPC::Run +object. It may take options in the future. + +=head2 start + +This is the more complex method to start a program running. When you call this +method, the program you specify is started right away and it's PID (process ID) +is returned to you. After you call this you will either need to call +C or C to start getting the programs or code +references output. See L<"do_loop"> and L<"do_one_loop"> else where in this +document. + +This method takes a hash of arguments. The arguments are: + +=over 4 + +=item program + +The name of the program, or code reference you wish to run. This is treated +the same way as the first argument to L. See L<"run"> else where in +this document for a description of how this argument is treated. + +=item stdout + +This is how you want STDOUT treated. It can be the same things as the second +argument to L. See L<"run"> else where in this document for a +description of how this argument is treated. + +=item stderr + +This is how you want STDERR treated. It can be the same things as the third +argument to L. See L<"run"> else where in this document for a +description of how this argument is treated. + +=item stdin + +This argument is how to handle STDIN. It may be one of two things. It is +treated like the forth argument to L. See L<"run"> else where in this +document for a description of how this argument is treated. + +=item reaper + +This is a code reference that will be ran once a process has exited. Note: the +process may not be done sending us STDOUT or STDERR when it exits. + +The code reference is called with the pid as it's first argument and the exit +status of the program for its second argument. The exit status is the same as +it is returned by waitpid(). The exit status is somewhat fiddled on Windows to +act the way you want it to, e.g. C<$exit_status EE 8> will be the +number the program exited with. + +=item done_callback + +This is a code reference that works similarly to reaper except that it is only +called after the child has died AND all STDOUT/STDERR output has been sent, +unlike reaper which is called on exit, regardless of any output that may still +be pending. + +The code reference is called wih the pid and exit status of the program as its +two arguments. + +=back + +=head2 do_one_loop + +This method takes one argument, the time to wait for C to return +something in milliseconds. This does one select loop on all the processes. You +will need to called this after you call C. Typically: + + my $ipc = new GT::IPC::Run; + my $pid = $ipc->start(program => 'ls'); + 1 while $ipc->do_one_loop; + my $exit_status = $ipc->exit_code($pid); + + +=head2 do_loop + +This is similar to C, except it does not return unless all +processes are finished. Almost the same as: + + 1 while $ipc->do_one_loop; + +You can pass the wait time to C and it will be passed on to +C. The wait time is in milliseconds. + +=head2 exit_code + +This method takes a pid as an argument and returns the exit status of that +processes pid. If the process has not exited yet or GT::IPC::Run did not launch +the process, returns undefined. The exit code returned by this is the same as +returned by waitpid. See L and L. + +=head1 SEE ALSO + +See L, L, L, L, and +L. + +=head1 MAINTAINER + +Scott Beck + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm new file mode 100644 index 0000000..d9f65ad --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm @@ -0,0 +1,47 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Run::Child +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Child.pm,v 1.2 2002/04/24 04:07:18 alex Exp $ +# +# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Child storrage class +# + +package GT::IPC::Run::Child; +# ================================================================== + +use strict; + +sub new { + my $class = shift; + my %self = @_; + bless \%self, $class; + return \%self; +} + +sub program { if (@_ > 1) { $_[0]->{program} = $_[1]; } return $_[0]->{program}; } +sub stderr_read { if (@_ > 1) { $_[0]->{stderr_read} = $_[1]; } return $_[0]->{stderr_read}; } +sub stderr_write { if (@_ > 1) { $_[0]->{stderr_write} = $_[1]; } return $_[0]->{stderr_write}; } +sub stdout_read { if (@_ > 1) { $_[0]->{stdout_read} = $_[1]; } return $_[0]->{stdout_read}; } +sub stdout_write { if (@_ > 1) { $_[0]->{stdout_write} = $_[1]; } return $_[0]->{stdout_write}; } +sub stdin_read { if (@_ > 1) { $_[0]->{stdin_read} = $_[1]; } return $_[0]->{stdin_read}; } +sub stdin_write { if (@_ > 1) { $_[0]->{stdin_write} = $_[1]; } return $_[0]->{stdin_write}; } +sub stdin { if (@_ > 1) { $_[0]->{stdin} = $_[1]; } return $_[0]->{stdin}; } +sub handler_stdout { if (@_ > 1) { $_[0]->{handler_stdout} = $_[1]; } return $_[0]->{handler_stdout}; } +sub handler_stderr { if (@_ > 1) { $_[0]->{handler_stderr} = $_[1]; } return $_[0]->{handler_stderr}; } +sub exit_callback { if (@_ > 1) { $_[0]->{exit_callback} = $_[1]; } return $_[0]->{exit_callback}; } +sub done_callback { if (@_ > 1) { $_[0]->{done_callback} = $_[1]; } return $_[0]->{done_callback}; } +sub exit_status { if (@_ > 1) { $_[0]->{exit_status} = $_[1]; } return $_[0]->{exit_status}; } +sub pid { if (@_ > 1) { $_[0]->{pid} = $_[1]; } return $_[0]->{pid}; } +sub called_reaper { if (@_ > 1) { $_[0]->{called_reaper} = $_[1]; } return $_[0]->{called_reaper}; } +sub process { if (@_ > 1) { $_[0]->{process} = $_[1]; } return $_[0]->{process}; } +sub forked { if (@_ > 1) { $_[0]->{forked} = $_[1]; } return $_[0]->{forked}; } +sub called_done { if (@_ > 1) { $_[0]->{called_done} = $_[1]; } return $_[0]->{called_done}; } + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Select.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Select.pm new file mode 100644 index 0000000..7ace2f2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Select.pm @@ -0,0 +1,131 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Run::Select +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Select.pm,v 1.6 2004/01/13 01:35:17 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Select IO for children handles +# + +package GT::IPC::Run::Select; +# ================================================================== + +use strict; + +use POSIX qw(errno_h); +use constants + STDOUT_FN => 0, + STDERR_FN => 1; + +sub new { +# ------------------------------------------------------------------------ + my ($class) = @_; + return bless {}, $class; +} + +sub add_stdout { +# ------------------------------------------------------------------------ + my ($self, $pid, $stdout) = @_; + my $bits = delete $self->{vec_bits}; + $bits = '' unless defined $bits; + + if (defined $stdout) { + my $stdout_fn = fileno($stdout); + vec($bits, $stdout_fn, 1) = 1; + $self->{$pid}[STDOUT_FN] = $stdout_fn; + } + $self->{vec_bits} = $bits; +} + +sub add_stderr { +# ------------------------------------------------------------------------ + my ($self, $pid, $stderr) = @_; + my $bits = delete $self->{vec_bits}; + $bits = '' unless defined $bits; + + if (defined $stderr) { + my $stderr_fn = fileno($stderr); + vec($bits, $stderr_fn, 1) = 1; + $self->{$pid}[STDERR_FN] = $stderr_fn; + } + $self->{vec_bits} = $bits; +} + +sub remove_stdout { +# ------------------------------------------------------------------------ + my ($self, $pid) = @_; + my $bits = delete $self->{vec_bits}; + $bits = '' unless defined $bits; + + my $fn = $self->{$pid}[STDOUT_FN]; + if (defined $fn) { + vec($bits, $fn, 1) = 0; + undef $self->{$pid}[STDOUT_FN]; + } + $self->{vec_bits} = $bits; +} + +sub remove_stderr { +# ------------------------------------------------------------------------ + my ($self, $pid) = @_; + my $bits = delete $self->{vec_bits}; + $bits = '' unless defined $bits; + + my $fn = $self->{$pid}[STDERR_FN]; + if (defined $fn) { + vec($bits, $fn, 1) = 0; + undef $self->{$pid}[STDERR_FN]; + } + $self->{vec_bits} = $bits; +} + +sub can_read { +# ------------------------------------------------------------------------ + my ($self, $timeout) = @_; + my $bits = delete $self->{vec_bits}; + my $sbits = $bits; + + local $!; + my $nfound; + do { + $! = 0; + $nfound = select($sbits, undef, undef, $timeout); + } while $! == EINTR; + if (defined $sbits and $nfound > 0) { + my (@stdout_waiting, @stderr_waiting); + for my $pid (keys %$self ) { + my $child = $self->{$pid}; + if (!defined $self->{$pid}[STDOUT_FN] and !defined $self->{$pid}[STDERR_FN]) { + delete $self->{$pid}; + next; + } + if (defined $child->[STDOUT_FN] and (!defined $sbits or vec($sbits, $child->[STDOUT_FN], 1))) { + push @stdout_waiting, $pid; + } + if (defined $child->[STDERR_FN] and (!defined $sbits or vec($sbits, $child->[STDERR_FN], 1))) { + push @stderr_waiting, $pid; + } + } + if (!@stdout_waiting and !@stderr_waiting) { + $self->debug( + "Select said we have nfound, but did not find anything pending!" + ) if $self->{_debug}; + } + $self->{vec_bits} = $bits; + return(\@stdout_waiting, \@stderr_waiting); + } + elsif ($nfound < 0) { + $self->debug("Socket error: $!") if $self->{_debug}; + } + $self->{vec_bits} = $bits; + return [], []; +} + +1; + + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Unix.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Unix.pm new file mode 100644 index 0000000..8a4265a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Unix.pm @@ -0,0 +1,306 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Run::Unix +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Unix.pm,v 1.24 2004/02/17 01:33:07 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== + +package GT::IPC::Run::Unix; + +use strict; +use vars qw/$EVENTS $ERROR_MESSAGE/; +use base 'GT::Base'; + +use IO::Select; +use POSIX qw(fcntl_h errno_h :sys_wait_h); + +sub READ_BLOCK () { 512 } + +@GT::IPC::Run::Unix::ISA = qw(GT::IPC::Run); +$ERROR_MESSAGE = 'GT::IPC::Run'; + +sub execute { +# ------------------------------------------------------------------------ + my ($self) = @_; + +# unless ($self->{sigchld_installed}) { +# $self->{chld_signal} = sub { +# my $child; +# while (($child = waitpid -1, WNOHANG) > 0) { +# $self->{goners}{$child} = $?; +# $self->debug( +# "forked child $child exited with exit status (". +# ($self->{goners}{$child} >> 8). +# ")\n" +# ) if $self->{_debug}; +# } +# $SIG{CHLD} = $self->{chld_signal}; +# }; +# $SIG{CHLD} = $self->{chld_signal}; +# $self->{sigchld_installed} = 1; +# } + +# Create a semaphore pipe. This is used so that the parent doesn't +# begin listening until the child's stdio has been set up. + my ($child_pipe_read, $child_pipe_write) = $self->oneway; + die "Could not create semaphore socket: $!" unless defined $child_pipe_read; + + my $pid; + if ($pid = fork) { # Parent + my $child = delete $self->{current_child}; + $self->{select}->add_stdout($pid => $child->stdout_read); + $self->{select}->add_stderr($pid => $child->stderr_read); + $self->{children}{$pid} = $child; + $child->pid($pid); + if ($child->stdin and ref($child->stdin) eq 'SCALAR') { + print {$child->stdin_write} ${$child->stdin}; + close $child->stdin_write; + } + + # Cludge to stop speed forking + select undef, undef, undef, 0.001; + + # Close what the parent will not need +# close $child->stdout_write if $child->stdout_write; +# close $child->stderr_write if $child->stderr_write; +# close $child->stdin_read if $child->stdin_read; + <$child_pipe_read>; + close $child_pipe_read; + close $child_pipe_write; + return $pid; + } + else { + $self->fatal(FORK => "$!") unless defined $pid; + $self->debug("Forked: $$\n") if $self->{_debug} > 1; + + # Get out self and out filenos + my $self = delete $self->{current_child}; + my ($stdout_fn, $stderr_fn, $stdin_fn); + $stdout_fn = fileno($self->stdout_write) if $self->stdout_write; + $stderr_fn = fileno($self->stderr_write) if $self->stderr_write; + $stdin_fn = fileno($self->stdin_read) if $self->stdin_read; + # Close what the child won't need. +# close $self->stdin_write if $self->stdin_write; +# close $self->stderr_read if $self->stderr_read; +# close $self->stdout_read if $self->stdout_read; + +# Tied handles break this + untie *STDOUT if tied *STDOUT; + untie *STDERR if tied *STDERR; + untie *STDIN if tied *STDIN; + + # Redirect STDOUT to the write end of the stdout pipe. + if (defined $stdout_fn) { + $self->debug("Opening stdout to fileno $stdout_fn") if $self->{_debug}; + open( STDOUT, ">&$stdout_fn" ) + or die "can't redirect stdout in child pid $$: $!"; + $self->debug("stdout opened") if $self->{_debug}; + } + + # Redirect STDIN from the read end of the stdin pipe. + if (defined $stdin_fn) { + $self->debug("Opening stdin to fileno $stdin_fn") if $self->{_debug}; + open( STDIN, "<&$stdin_fn" ) + or die "can't redirect STDIN in child pid $$: $!"; + $self->debug("stdin opened") if $self->{_debug}; + } + + # Redirect STDERR to the write end of the stderr pipe. + if (defined $stderr_fn) { + $self->debug("Opening stderr to fileno $stderr_fn") if $self->{_debug}; + open( STDERR, ">&$stderr_fn" ) + or die "can't redirect stderr in child: $!"; + } + + select STDERR; $| = 1; + select STDOUT; $| = 1; + + # Tell the parent that the stdio has been set up. + close $child_pipe_read; + print $child_pipe_write "go\n"; + close $child_pipe_write; + + # Program code here + my $program = $self->program; + if (ref($program) eq 'ARRAY') { + exec(@$program) or do { + print STDERR "can't exec (@$program) in child pid $$:$!\n"; + eval { POSIX::_exit($?); }; + eval { kill KILL => $$; }; + }; + } + elsif (ref($program) eq 'CODE') { + $? = 0; + $program->(); + + # In case flushing them wasn't good enough. + close STDOUT if defined fileno(STDOUT); + close STDERR if defined fileno(STDERR); + + eval { POSIX::_exit($?); }; + eval { kill KILL => $$; }; + } + else { + exec($program) or do { + print STDERR "can't exec ($program) in child pid $$:$!\n"; + eval { POSIX::_exit($?); }; + eval { kill KILL => $$; }; + }; + } + die "How did I get here!"; + } +} + +sub put { +# ------------------------------------------------------------------------ + my $self = shift; + my $pid = shift; + print {$self->{children}{$pid}->stdin_write} @_; +} + +sub do_one_loop { +# ------------------------------------------------------------------------ + my ($self, $wait) = @_; + $wait = 0.05 unless defined $wait; + + # See if any children have exited + my $child; + while (($child = waitpid -1, WNOHANG) > 0) { + next unless exists $self->{children}{$child}; + $self->{goners}{$child} = $?; + $self->{children}{$child}->exit_status($?); + $self->debug( + "forked child $child exited with exit status (". + ($self->{goners}{$child} >> 8). + ")\n" + ) if $self->{_debug}; + } + + for my $pid (keys %{$self->{goners}} ) { + my $child = $self->{children}{$pid} or next; + if (!$child->called_reaper) { + $child->exit_callback->($pid, $self->{goners}{$pid}) + if $child->exit_callback; + $child->called_reaper(1); + } + } + my ($stdout_pending, $stderr_pending) = $self->{select}->can_read($wait); + + my %not_pending = %{$self->{children}}; + for my $pid (@$stdout_pending, @$stderr_pending) { + delete $not_pending{$pid}; + } + for my $pid (keys %{$self->{goners}}) { + my $child = $self->{children}{$pid} or next; + if ($not_pending{$pid} and not $child->called_done) { + $child->done_callback->($pid, $self->{goners}{$pid}) + if $child->done_callback; + $child->called_done(1); + } + } + + if (!@$stdout_pending and !@$stderr_pending) { + $self->debug("Nothing else to do, flushing buffers") + if $self->{_debug}; + $self->debug( + "Children: ". + keys(%{$self->{children}}). + "; goners: ". + keys(%{$self->{goners}}) + ) if $self->{_debug}; + + # We still have children out there + return 1 if keys(%{$self->{children}}) > keys(%{$self->{goners}}); + + # Flush output filters and delete children to free memory and FDs + $self->flush_filters; + + # Nothing left to do + return 0; + } + # else we have stuff to do + for my $pid (@$stdout_pending) { + my $child = $self->{children}{$pid}; + $self->debug("STDOUT pending for $pid") if $self->{_debug}; + + my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK); + if (!$ret) { + if ($! != EAGAIN and $! != 0) { + # Socket error + $self->debug( + "$pid: Socket Read: $!: $^E; Errno: ", 0+$! + ) if $self->{_debug}; + } + } + else { + # Process callbacks + $self->debug("[$pid STDOUT]: `$buff'\n") + if $self->{_debug} > 1; + if ($child->handler_stdout) { + $child->handler_stdout->put(\$buff); + } + } + } + for my $pid (@$stderr_pending) { + my $child = $self->{children}{$pid}; + $self->debug("STDERR pending for $pid") if $self->{_debug}; + + my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK); + if (!$ret) { + if ($! != EAGAIN and $! != 0) { + # Socket error + $self->debug( + "$pid: Socket Read: $!: $^E; Errno: ", 0+$! + ) if $self->{_debug}; + } + } + else { + # Process callbacks + $self->debug("[$pid STDERR]: `$buff'\n") + if $self->{_debug} > 1; + if ($child->handler_stderr) { + $child->handler_stderr->put(\$buff); + } + } + } + return 1; +} + +sub flush_filters { +# ------------------------------------------------------------------------ + my $self = shift; + for my $pid (keys %{$self->{children}}) { + my $child = delete $self->{children}{$pid}; + $self->select->remove_stdout($pid); + $self->select->remove_stderr($pid); + if ($child->handler_stdout) { + $child->handler_stdout->flush; + } + if ($child->handler_stderr) { + $child->handler_stderr->flush; + } + } +} + +sub stop_blocking { +# ------------------------------------------------------------------------ + my ($self, $socket_handle) = @_; + my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!"; + $flags = fcntl($socket_handle, F_SETFL, $flags | O_NONBLOCK) + or die "setfl: $!"; +} + +sub start_blocking { +# ------------------------------------------------------------------------ + my ($self, $socket_handle) = @_; + my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!"; + $flags = fcntl($socket_handle, F_SETFL, $flags & ~O_NONBLOCK) + or die "setfl: $!"; +} + + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm new file mode 100644 index 0000000..ce47552 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm @@ -0,0 +1,505 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPC::Run::Win32 +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Win32.pm,v 1.16 2006/03/30 18:40:22 sbeck Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== + +package GT::IPC::Run::Win32; + +use strict; +use vars qw/$EVENTS $ERROR_MESSAGE/; +use base 'GT::Base'; + +use POSIX qw(fcntl_h errno_h :sys_wait_h); +use GT::Lock qw/lock unlock/; +use Win32; +use Win32::Process; +use Win32::Mutex; +sub READ_BLOCK () { 512 } + +# What Win32 module exports this? +sub WSAEWOULDBLOCK () { 10035 } + +@GT::IPC::Run::Win32::ISA = qw(GT::IPC::Run); + +$ERROR_MESSAGE = 'GT::IPC::Run'; + +sub execute { +# ------------------------------------------------------------------------ + my ($self) = @_; + + my $pid; + my $child = $self->{current_child}; + if (ref($child->program) eq 'ARRAY' or !ref($child->program)) { + my $process = $self->fork_exec; + $child->pid($process->GetProcessID); + $child->process($process); + } + else { + $child->pid($self->fork_code); + $child->forked(1); + } + $self->{children}{$child->pid} = delete $self->{current_child}; + return $child->pid; +} + +sub put { +# ------------------------------------------------------------------------ + my $self = shift; + my $pid = shift; + print {$self->{children}{$pid}->stdin_write} @_; +} + +sub fork_exec { +# ------------------------------------------------------------------------ +# Called on Win32 systems when wanting to exec() a process. This replaces +# forking and executing. You cannot get filehandle inheritance when exec() +# after a fork, fun stuff. + my $self = shift; + + + my $child = $self->{current_child}; + my $process = ''; + my $program = ref($child->program) eq 'ARRAY' + ? $child->program + : [split ' ', $child->program]; + open STDOUT_SAVE, ">&STDOUT"; + open STDERR_SAVE, ">&STDERR"; + open STDIN_SAVE, "<&STDIN"; + + # Redirect STDOUT to the write end of the stdout pipe. + if ($child->stdout_write) { + my $fn = fileno($child->stdout_write); + if (defined $fn) { + $self->debug("Opening stdout to fileno $fn") if $self->{_debug}; + open( STDOUT, ">&$fn" ) + or die "can't redirect stdout in child pid $$: $!"; + $self->debug("stdout opened") if $self->{_debug}; + } + else { + die "No fileno for stdout_write"; + } + } + + # Redirect STDIN from the read end of the stdin pipe. + if ($child->stdin_read) { + my $fn = fileno($child->stdin_read); + if (defined $fn) { + $self->debug("Opening stdin to fileno $fn") if $self->{_debug}; + open( STDIN, "<&$fn" ) + or die "can't redirect STDIN in child pid $$: $!"; + $self->debug("stdin opened") if $self->{_debug}; + } + else { + die "No fileno for stdin_read"; + } + } + + # Redirect STDERR to the write end of the stderr pipe. + if ($child->stderr_write) { + my $fn = fileno($child->stderr_write); + if (defined $fn) { + $self->debug("Opening stderr to fileno $fn") if $self->{_debug}; + open( STDERR, ">&$fn" ) + or die "can't redirect stderr in child: $!"; + } + else { + die "No fileno for stderr_write"; + } + } + + select STDOUT; $| = 1; + select STDERR; $| = 1; + select STDOUT; + Win32::Process::Create( + $process, + $program->[0], + "@$program", + 1, + NORMAL_PRIORITY_CLASS, + '.' + ) or do { + open STDOUT, ">&STDOUT_SAVE"; + open STDERR, ">&STDERR_SAVE"; + open STDIN, "<&STDIN_SAVE"; + die "can't exec (@$program) using Win32::Process; Reason: ". + Win32::FormatMessage(Win32::GetLastError); + }; + syswrite($child->stdin_write, ${$child->stdin}, length(${$child->stdin}), 0) + if ref($child->stdin) eq 'SCALAR'; + open STDOUT, ">&STDOUT_SAVE"; + open STDERR, ">&STDERR_SAVE"; + open STDIN, "<&STDIN_SAVE"; + return $process; +} + +sub fork_code { +# ------------------------------------------------------------------------ + my $self = shift; + + # Hack to keep from forking too many process too fast, perl on windows + # tends to segv when that happens + select undef, undef, undef, 0.5; + + # So we know when the child is finished setting up + my $mutex = new Win32::Mutex(1, 'CHILD'); + my $pid; + if ($pid = fork) { # Parent + my $child = $self->{current_child}; + $mutex->wait(2000); + print {$child->stdin_write} ${$child->stdin} + if ref($child->stdin) eq 'SCALAR'; + return $pid; + } + else { + $self->fatal( FORK => "$!" ) unless defined $pid; + $self->debug("Forked: $$\n") if $self->{_debug} > 1; + + # Hack to keep the child from destroying the mutex + { + package GT::IPC::Run::Mutex; + @GT::IPC::Run::Mutex::ISA = 'Win32::Mutex'; + sub DESTROY {} + } + bless $mutex, 'GT::IPC::Run::Mutex'; + + my $child = $self->{current_child}; + my ($stdout, $stderr, $stdin) = ( + $child->stdout_write, + $child->stderr_write, + $child->stdin_read + ); + + # Redirect STDOUT to the write end of the stdout pipe. + if (defined $stdout) { + *STDOUT = $stdout; + $self->debug("stdout opened") if $self->{_debug}; + } + + # Redirect STDIN from the read end of the stdin pipe. + if (defined $stdin) { + *STDIN = $stdin; + $self->debug("stdin opened") if $self->{_debug}; + } + + # Redirect STDERR to the write end of the stderr pipe. + if (defined $stderr) { + *STDERR = $stderr; + } + + select STDERR; $| = 1; + select STDOUT; $| = 1; + + # Tell the parent that the stdio has been set up. + $mutex->release; + + # Launch the code reference + $child->program->(); + close STDOUT if defined fileno STDOUT; + close STDERR if defined fileno STDERR; + exit(0); + } +} + +sub do_one_loop { +# ------------------------------------------------------------------------ + my ($self, $wait) = @_; + $wait = 0.05 unless defined $wait; + + $self->check_for_exit; + $self->debug( + "Children: ". keys(%{$self->{children}}). + "; goners: ". keys(%{$self->{goners}}) + ) if $self->{_debug}; + + for my $pid (keys %{$self->{children}}) { + my $child = $self->{children}{$pid}; + + if ($child->stdout_read) { + my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK); + if (!$ret) { + # Fun stuff with win32 + if ($! == EAGAIN) { + # Socket error + #$self->{select}->remove_stdout($pid); + $self->debug( + "1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug}; + } + elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) { + $child->{socket_err}++; + $self->debug( + "2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug} > 1; + } + else { + $child->{socket_err}++; + $self->debug( + "2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug} > 1; + } + } + else { + # Process callbacks + $self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1; + if (defined $child->handler_stdout) { + $child->handler_stdout->put(\$buff); + } + } + } + if ($child->stderr_read) { + my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK); + if (!$ret) { + # Fun stuff with win32 + if ($! == EAGAIN) { + # Socket error + #$self->{select}->remove_stderr($pid); + $self->debug( + "1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug}; + } + elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) { + $child->{socket_err}++; + $self->debug( + "2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug} > 1; + } + else { + $child->{socket_err}++; + $self->debug( + "2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E) + ) if $self->{_debug} > 1; + } + } + else { + # Process callbacks + $self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1; + if (defined $child->handler_stderr) { + $child->handler_stderr->put(\$buff); + } + } + } + } + # Call the "done" callback for anything that has exited and has no pending output + my %not_pending = %{$self->{children}}; + for my $child (values %{$self->{children}}) { + if ($child->{socket_err} >= 2) { + delete $not_pending{$child->{pid}}; + } + } + for my $pid (keys %{$self->{goners}}) { + my $child = $self->{children}{$pid} or next; + if ($not_pending{$pid} and not $child->called_done) { + $child->done_callback->($pid, $self->{goners}{$pid}) + if $child->done_callback; + $child->called_done(1); + } + } + + my $done; + for my $child (values %{$self->{children}}) { + if ($child->{socket_err} >= 2) { + $done++; + } + } + if ($done == keys %{$self->{children}} and (keys(%{$self->{children}}) <= keys(%{$self->{goners}}))) { + # We still have children out there + if (keys(%{$self->{children}}) > keys(%{$self->{goners}})) { + $self->debug("We still have children") if $self->{_debug}; + return 1; + } + + $self->debug("Nothing else to do, flushing buffers") + if $self->{_debug}; + + # Flush output filters + for my $pid (keys %{$self->{children}}) { + my $child = delete $self->{children}{$pid}; + $self->select->remove_stdout($pid); + $self->select->remove_stderr($pid); + if ($child->handler_stdout) { + $child->handler_stdout->flush; + } + if ($child->handler_stderr) { + $child->handler_stderr->flush; + } + } + + # Nothing left to do + $self->debug("Returning 0") if $self->{_debug}; + return 0; + } + +# for my $pid (@$stdout_pending) { +# my $child = $self->{children}{$pid}; +# $self->debug("STDOUT pending for $pid") if $self->{_debug}; +# +# my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK); +# if (!$ret) { +# # Fun stuff with win32 +# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) { +# # Socket error +# $self->{select}->remove_stdout($pid); +# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E)) +# if $self->{_debug}; +# } +# else { +# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E)) +# if $self->{_debug}; +# } +# } +# else { +# # Process callbacks +# $self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1; +# if (defined $child->handler_stdout) { +# $child->handler_stdout->put(\$buff); +# } +# } +# } +# +# for my $pid (@$stderr_pending) { +# my $child = $self->{children}{$pid}; +# $self->debug("STDERR pending for $pid") if $self->{_debug}; +# +# my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK); +# if (!$ret) { +# # Fun stuff with win32 +# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) { +# # Socket error +# $self->{select}->remove_stderr($pid); +# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E)) +# if $self->{_debug}; +# } +# else { +# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E)) +# if $self->{_debug}; +# } +# } +# else { +# # Process callbacks +# $self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1; +# if (defined $child->handler_stderr) { +# $child->handler_stderr->put(\$buff); +# } +# } +# } + return 1; +} + +my $warned; +sub check_for_exit { +# ------------------------------------------------------------------------ + my ($self) = @_; + # This process was created with Win32::Process. The problem is + # there is no way to reliably get the output from a Win32::Process + # program in a loop like this. Output handles are not flushed when + # process exits, which means that if it blocks a little we will + # likly lose the last output it produces, this is so not nice. + for my $pid (keys %{$self->{children}}) { + my $child = $self->{children}{$pid}; + next if exists $self->{goners}{$pid}; + + if ($child->forked) { + # Check if the program exited + my $got_pid; + my $waited = waitpid($pid, WNOHANG); + my $killed = 1; + $self->debug("waited: $waited; pid: $pid") + if $self->{_debug}; + if ($waited < -1) { + $self->{goners}{$pid} = $?; + $child->exit_callback->($pid, $?) + if $child->exit_callback; + $self->debug( + "forked child $pid exited with exit status (". + ($self->{goners}{$pid} >> 8). + ")\n" + ) if $self->{_debug}; + } + elsif ($waited == -1) { + $self->{goners}{$pid} = 0; + $child->exit_callback->($pid, 0) + if $child->exit_callback; + } +# elsif ($waited == -1) { +# for my $pid (keys %{$self->{children}}) { +# $self->{select}->remove_stdout($pid); +# $self->{select}->remove_stderr($pid); +# unless (exists $self->{goners}{$pid}) { +# $self->{goners}{$pid} = -1; +# $self->{children}{$pid}{exit_callback}->($pid, -1) +# if $self->{children}{$pid}{exit_callback}; +# } +# } +# } +# elsif (!$killed) { +# $self->{goners}{$pid} = -1; +# $self->{children}{$pid}{exit_callback}->($pid, -1) +# if $self->{children}{$pid}{exit_callback}; +# $self->debug( "Could not get exit status of $pid") +# if $self->{_debug}; +# } + } + else { + + $self->debug("Checking if $pid is running") if $self->{_debug}; + if ($child->process and $child->process->Wait(0)) { + $self->{goners}{$pid} = ''; + my $exit_code; + $child->process->GetExitCode($exit_code); + $self->{goners}{$pid} = $exit_code << 8; + $child->exit_callback->($pid, ($exit_code << 8)) + if $child->exit_callback; + $self->debug("$pid exited with status: $self->{goners}{$pid}") + if $self->{_debug}; + } + elsif ($self->{_debug}) { + $self->debug("$pid is still running"); + } + } + } +} + +sub oneway { +# ------------------------------------------------------------------------ + my ($self) = @_; + $self->SUPER::oneway('inet'); +} + +sub twoway { +# ------------------------------------------------------------------------ + my ($self) = @_; + $self->SUPER::twoway('inet'); +} + +sub stop_blocking { +# ------------------------------------------------------------------------ + my ($self, $socket_handle) = @_; + my $set_it = "1"; + + # 126 is FIONBIO (some docs say 0x7F << 16) + ioctl( $socket_handle, + 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, + $set_it + ) or die "ioctl: $^E"; +} + +sub start_blocking { +# ------------------------------------------------------------------------ + my ($self, $socket_handle) = @_; + my $unset_it = "0"; + + # 126 is FIONBIO (some docs say 0x7F << 16) + ioctl( $socket_handle, + 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, + $unset_it + ) or die "ioctl: $^E"; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/IPCountry.pm b/site/slowtwitch.com/cgi-bin/articles/GT/IPCountry.pm new file mode 100644 index 0000000..9683549 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/IPCountry.pm @@ -0,0 +1,172 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::IPCountry +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: IPCountry.pm,v 1.1 2006/01/31 00:45:04 jagerman Exp $ +# +# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# Attempts to look up an IP's country using a variety of common CPAN modules. +# + +package GT::IPCountry; +use strict; +require Exporter; + +use vars qw/@EXPORT @ISA %MODULE/; + +@ISA = 'Exporter'; +@EXPORT = 'ip_to_country'; + +sub lookup_possible () { + _load_module() if not defined $MODULE{loaded}; + return $MODULE{loaded}; +} + +sub ip_to_country ($) { + my $ip = shift; + + lookup_possible or return (undef, undef); + + my $country; + + if ($MODULE{geoip}) { # Geo::IP + $country = $MODULE{geoip}->country_name_by_addr($ip); + } + elsif ($MODULE{ipc}) { # IP::Country & Geography::Countries + $country = $MODULE{ipc}->inet_ntocc(Socket::inet_aton($ip)); + my %special = ( # Special codes returned that G::C can't handle: + AP => 'non-specific Asia-Pacific location', + CS => 'Czechoslovakia (former)', + EU => 'non-specific European Union location', + FX => 'France, Metropolitan', + PS => 'Palestinian Territory, Occupied', + '**' => 'Intranet address' + ); + if ($special{$country}) { $country = $special{$country} } + elsif ($MODULE{geoc}) { + $country = Geography::Countries::country($country) || $country; + } + } + elsif ($MODULE{geoipfree}) { # Geo::IPfree + $country = ($MODULE{geoipfree}->LookUp($ip))[1]; + } + + return wantarray ? ($country, 1) : $country; +} + +# Attempts to load various CPAN modules capable of going the IP -> country +# lookup. Sets $MODULE{loaded} to 1 if at least one of the modules was found, +# sets to 0 if none were loadable. +sub _load_module { + + if (!defined $MODULE{geoip}) { + $MODULE{geoip} = eval { require Geo::IP; Geo::IP->new(Geo::IP::GEOIP_STANDARD()) } || 0; + if (!$MODULE{geoip}) { + $MODULE{geoipfree} = 0 && eval { require Geo::IPfree; Geo::IPfree->new } || 0; + } + if (!$MODULE{geoip}) { + $MODULE{ipc} = eval { require IP::Country::Fast; IP::Country::Fast->new } || 0; + } + if ($MODULE{ipc}) { + require Socket; + $MODULE{geoc} = eval { require Geography::Countries } || 0; + } + if (!$MODULE{ipc} and !$MODULE{geoipfree}) { + $MODULE{geoipfree} = 0 && eval { require Geo::IPfree; Geo::IPfree->new } || 0; + } + } + + $MODULE{loaded} = $MODULE{geoip} || $MODULE{geoipfree} || $MODULE{ipc} ? 1 : 0; +} + +1; + +__END__ + +=head1 NAME + +GT::IPCountry - Attempts to look up an IP's country using a variety of common +CPAN modules. + +=head1 SYNOPSIS + + use GT::IPCountry; + + my $country = ip_to_country("209.139.239.160"); + + my ($country, $lookup_okay) = ip_to_country("209.139.239.160"); + + my $can_lookup = GT::IPCountry::lookup_possible(); + +=head1 DESCRIPTION + +This module takes an IP address and returns the country name the IP is reserved +for. This module itself does no actual lookup, but is simply a wrapper around +serveral CPAN modules. If none of the modules are available, it simply returns +the value C. + +=head1 FUNCTIONS + +=head2 ip_to_country + +This method takes a country name and returns two elements: the country name, +and a true/false value indicating whether one of the lookup modules was +available. In scalar context just the country name is returned. A country +name of C indicates that either the IP wasn't found, or no lookup module +was available. + +C is exported by default. + +=head2 lookup_possible + +This method returns a true/false value indicating whether or not an IP -> +Country lookup can be done. It corresponds directly to the second return value +of C. + +=head1 MODULES + +GT::IPCountry attempts to use the following modules, in order, to perform a +country lookup: + +=over 4 + +=item Geo::IP + +Uses Geo::IP for the lookup. + +=item IP::Country + +Uses IP::Country for the lookup. Note that because IP::Country only returns a +country code, this module will attempt to use Geography::Countries to determine +the country name. If Geography::Countries isn't installed, you'll just get a +country code. + +=item Geo::IPfree + +Uses Geo::IPfree for the lookup. + +=back + +=head1 SEE ALSO + +L + +L + +L + +=head1 COPYRIGHT + +Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: IPCountry.pm,v 1.1 2006/01/31 00:45:04 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Image/Security.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Image/Security.pm new file mode 100644 index 0000000..a5be667 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Image/Security.pm @@ -0,0 +1,684 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Image::Security +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Security.pm,v 1.3 2006/11/03 18:55:35 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: Creates an image with specified text with mild +# alterations to rendered text and background to +# reduce machine legibility. +# + +package GT::Image::Security; +# ================================================================== + +use strict; +use vars qw/@ISA $ATTRIBS $ERRORS $DEBUG/; +use GT::Base; + +$DEBUG = 0; +@ISA = 'GT::Base'; + +$ATTRIBS = { + text => '', + + height => undef, # undef == automatic + width => undef, # undef == automatic + image_type => undef, # undef == automatic + + fonts_path => undef, + +# Since this module will probably be working with the Bitstream fonts, +# the module by default has the settings to remove the fonts that are +# difficult to read + exclude_fonts => [qw( Vera.ttf VeraIt.ttf VeraMoIt.ttf VeraMono.ttf VeraSe.ttf )], + +# The number of steps each colour has. As truecolour +# is not being used automatically, 5 appears to be safest +# value that regresses nicely across versions + colour_steps => 5, + +# invert the intensity colours on the image? + invert => undef, # undef == automatic + + max_x_wobble => 20, + max_y_wobble => 20, + max_ang_wobble => 30, + base_pt => 30, + max_pt_wobble => 15, + max_obfuscates => undef, # undef == automatic + padding => 10, + + display_chars => undef, # undef == automatic + +# The following attributes are listed reference just as +# purposes. They shouldn't be used by the invoking application. + _use_ttf => 1, + _fonts => undef, + _keyimage => undef, +}; + +$ERRORS = { + IMG_GD_FAIL => 'Could not load GD. (%s)', + IMG_FONT_PATH => 'Could not open font path (%s)', + IMG_INIT_FAIL => 'Could not initialize image.', + IMG_TYPE_FAIL => 'Could not determine if GD could render an image', + IMG_DRAW_FAIL => 'Could not draw image because (%s).', + IMG_DATA_FAIL => 'Could not generate data for image because (%s)' +}; + +sub new { +# ------------------------------------------------------------------- +# Test to make sure GD is available on the system. If not, returns +# undef and records the error +# + my $class = shift; + local $@; + eval { require GD }; + return $class->warn( IMG_GD_FAIL => "$@" ) if $@; + return $class->SUPER::new( @_ ); +} + +sub init_fonts { +# ------------------------------------------------------------------- +# This loads the fonts, tests to see if the system can handle truetype +# and if it can't, switches the system over to internal fonts +# + my $self = shift; + +# Find out if this system allows ttf to be used. + my $use_ttf = UNIVERSAL::can( 'GD::Image', 'stringFT' ); + + my @fonts; + +# If the GD module supports the stringFT function +# which is used to render TrueType fonts onto the +# image, let's see if we can load a couple of TTF files + if ( $use_ttf and defined $self->{fonts_path} ) { + my $exclude_font_lookup = { + map {( lc $_ => 1 )} @{$self->{exclude_fonts}} + }; + + $self->debug( "Trying to load fonts from path: $self->{fonts_path}" ) if $self->{_debug}; + + -d $self->{fonts_path} or return $self->warn( IMG_FONT_PATH => $self->{fonts_path} ); + opendir( FONTSDIR, $self->{fonts_path} ) or return $self->warn( IMG_FONT_PATH => "$!" ); + + while ( my $f = readdir FONTSDIR ) { + next unless $f =~ /\.ttf/i; + next if $exclude_font_lookup->{lc $f}; + push @fonts, "$self->{fonts_path}/$f"; + } + closedir FONTSDIR; + +# Check to see that using the TTF support causes no errors +# We do this buy just faking a request to the function which +# simply returns. If there was an error, it should be set in +# $@ + if ( @fonts ) { + GD::Image->stringFT( 0, $fonts[0], 12, 0, 0, 0, 'GT' ); + $@ and $use_ttf = 0; + } + + unless ( defined $self->{max_obfuscates} ) { + $self->{max_obfuscates} = 10; + } + } + +# Something didn't work in our attempt to use the TTF features +# we'll setup to use just the standard built in font faces +# though they may be easily cracked with an OCR based system. + unless ( @fonts and $use_ttf ) { + +# change the max obfuscations to 3 as 10 would obliterate +# the legibility of the text + unless ( defined $self->{max_obfuscates} ) { + $self->{max_obfuscates} = 3; + } + @fonts = ( + GD::gdGiantFont(), +# The next set of fonts are far too small +# to be legible. The "Giant" font is rather +# tiny on the screen as well. +# GD::gdLargeFont() +# GD::gdSmallFont() +# GD::gdTinyFont() + ); + + $use_ttf = 0; + } + +# Debug output + if ( $self->{_debug} ) { + if ( $use_ttf ) { + $self->debug( "Using Truetype Fonts. The following fonts are loaded:" ); + foreach my $font ( @fonts ) { + $self->debug( " $font" ); + } + } + else { + $self->debug( "Using internal Fonts." ); + } + } + + $self->{_use_ttf} = $use_ttf; + $self->{_fonts} = \@fonts; +} + +sub init_image { +# -------------------------------------------------- +# Create the image and fill in the background. Has +# a secondary effect of initializing the text +# string and calculating bounds on each character. +# + my $self = shift; + + $self->{_keyimage} and return $self->{_keyimage}; + + my ( $mx, $my ) = $self->calculate_bounds( @_ ) or return; + + my $keyimage_width = $self->{width} ||= $mx + $self->{padding} * 2, + my $keyimage_height = $self->{height} ||= $my + $self->{padding} * 2; + + my $keyimage = $self->{_keyimage} = GD::Image->new( + $keyimage_width, + $keyimage_height + ) or return $self->warn( 'IMG_INIT_FAIL' ); + + $keyimage->fill( + 0, # x position to flood from + 0, # y position to flood from + $self->get_random_colour( -0.2 ) + ); + + return $keyimage; +} + +sub init_chars { +# -------------------------------------------------- +# This will take the text to be rendered and randomly +# choose values on how they will be rendered. +# + my $self = shift; + + $self->{text} = shift if @_; + my $text = $self->{text} or return; + + my @display_chars; + + my $fonts = $self->init_fonts or return; + + foreach my $ch ( split //, $text ) { + +# setup variable entities wobble + my $f = $fonts->[int( @$fonts * rand )]; + my $a = ( $self->{max_ang_wobble} * ( 0.5 - rand() ) ) * 0.01745; + my $y = int( rand() * $self->{max_y_wobble} ); + my $x = int( rand() * $self->{max_x_wobble} ); + my $p = $self->{base_pt} + ( int( $self->{max_pt_wobble} * ( 0.5 - rand() ) ) ); + +# the new character record. + my $char_rec = { + char => $ch, + font => $f, + angle => $a, + xoffset => $x, + yoffset => $y, + point => $p, + }; + + push @display_chars, $char_rec; + } + + $self->{display_chars} = \@display_chars; +} + +sub init_colour_matrix { +# -------------------------------------------------- +# This creates an NxNxN colour lookup matrix where +# N is equal to $self->{colour_steps}. This allows +# the fetching of colours quickly without need to +# create the colour entry in the swatch. +# + my $self = shift; + +# create the colour maps for the image + my $colour_steps = $self->{colour_steps}; + my $fraction = 255 / $colour_steps; + + my $colour_map = []; + for my $r ( 0..$colour_steps ) { + for my $g ( 0..$colour_steps ) { + for my $b ( 0..$colour_steps ) { + my @rgb = map { int( $_ * $fraction ) } ( $r, $g, $b ); + $colour_map->[$r][$g][$b] = $self->{_keyimage}->colorAllocate( @rgb ); + } + } + } + +# do we want to invert the colours with the randomizer? + unless ( defined $self->{invert} ) { + $self->{invert} = rand > 0.5 ? 1 : 0; + } + + $self->{colour_map} = $colour_map; +} + +sub draw_image { +# -------------------------------------------------- +# This method does the actual work of putting the +# characters onto a prepared image. +# + my $self = shift; + + my $display_chars = $self->{display_chars}; + my $keyimage = $self->init_image or return; + + my $offset = $self->{padding}; + my $obfuscate_count = 0; + +# If we have TTF support use that as the display +# chars have been prepared with TTF support in mind + if ( $self->{_use_ttf} ) { + local $@; + + foreach my $char_rec ( @$display_chars ) { + $keyimage->stringFT( + $self->get_random_colour( 0.6 ), + $char_rec->{font}, + $char_rec->{point}, + $char_rec->{angle}, + $offset, + $char_rec->{yoffset} + $self->{padding}, + $char_rec->{char} + ); + + return $self->warn( IMG_DRAW_FAIL => "$@" ) if $@; + + $offset += $char_rec->{xoffset}; + + if ( $obfuscate_count++ < $self->{max_obfuscates} ) { + $self->obfuscate_image; + } + } + } + +# Unfortunately, TTF support is not available so attempt +# to regress as nicely as possible + else { + foreach my $char_rec ( @$display_chars ) { + $keyimage->string( + $char_rec->{font}, + $offset, + $char_rec->{yoffset} + $self->{padding}, + $char_rec->{char}, + $self->get_random_colour( 0.6 ) + ); + + $offset += $char_rec->{xoffset}; + } + } + +# Finish up the obfuscations + while ( $obfuscate_count++ < $self->{max_obfuscates} ) { + $self->obfuscate_image; + } + + + return 1; + +} + +sub obfuscate_image { +# -------------------------------------------------- +# This randomly applies certain transformations to the +# key image to make it harder for machine readability. +# To add new obfuscation methods, the easiest way could +# be to subclass this module and override this function +# + my $self = shift; + + my $mode = int( 2 * rand() ); + + my $keyimage = $self->init_image or return; + my $keyimage_width = $self->{width}; + my $keyimage_height = $self->{height}; + +# Basic line + if ( $mode == 1 ) { + +# Find two edges to play with + my @edges = sort { $a->[2] <=> $b->[2] } ( + [ 0, int(rand()*$keyimage_height), rand ], # left + [ int(rand()*$keyimage_width), 0, rand], # top + [ $keyimage_width, int(rand()*$keyimage_height), rand], # right + [ int(rand()*$keyimage_width), $keyimage_height, rand ], # bottom + ); + + $keyimage->line( + @{$edges[0]}[0,1], + @{$edges[1]}[0,1], + $self->get_random_colour + ); + } + +# Draw a rectangle after acquiring two random points + else { + my @edges = ( + int(rand()*$keyimage_width), int(rand()*$keyimage_height), + int(rand()*$keyimage_width), int(rand()*$keyimage_height) + ); + + $keyimage->rectangle( + @edges, + $self->get_random_colour + ); + } + +} + +sub calculate_char_bounds { +# -------------------------------------------------- +# Finds out the bounds for a single character. Based +# upon the setting provided. +# + my ( $self, $char_rec ) = @_; + + my ( $vx, $vy ); + +# Must discern which of the methods are going to be +# used to display images. + if ( $self->{_use_ttf} ) { + +# calculate bounds + my @b = GD::Image->stringFT( + 0, + $char_rec->{font}, + $char_rec->{point}, + $char_rec->{angle}, + $char_rec->{xoffset}, + $char_rec->{yoffset}, + $char_rec->{char} + ); + +# The docs for bounds on stringFT suggested that +# the elements should be a bit more ordered but +# having had odd experiences with the values. Ensure +# value sanity + my ( $mxx, $mxy, $mix, $miy ) = (0,0,0,0); + for ( my $i = 0; $i < 4 ; $i++ ) { + my ( $x, $y ) = @b[$i*2,$i*2+1]; + $x > $mxx and $mxx = $x; + $x < $mix and $mix = $x; + $y > $mxy and $mxy = $y; + $y < $miy and $miy = $y; + } + + $vx = abs( $mxx - $mix ); + $vy = abs( $mxy - $miy ); + $char_rec->{yoffset} = $vy; + + } + else { + my $f = $char_rec->{font}; + $vx = $f->width() + $char_rec->{xoffset}; + $vy = $f->height() + $char_rec->{yoffset}; + } + + $char_rec->{xoffset} = $vx; + + return ( $vx, $vy ); +} + +sub get_random_colour { +# -------------------------------------------------- +# Returns a random GD image colour to be used in +# rendering fonts/lines/etc. The fraction value +# is optional and determines what portion of the +# palatte will be returned. A -1 < fraction < 0 will use +# the brightest n * 100% percent while a 0 < fraction < 1 +# will consider the darkest n * 100% as possible results +# + my ( $self, $fraction ) = @_; + + unless ( $self->{colour_map} ) { + $self->init_colour_matrix; + }; + + $fraction ||= 1; + $fraction *= ( $self->{invert} ? -1 : 1 ); + + my $colour_steps = $self->{colour_steps}; + + my @rgb; + + $fraction = $fraction * $colour_steps; + if ( $fraction > 0 ) { + @rgb = map { int($fraction*rand) } (1,2,3); + } + else { + @rgb = map { int($colour_steps+$fraction*rand) } (1,2,3); + } + + return $self->{colour_map}[$rgb[0]][$rgb[1]][$rgb[2]]; + +} + +sub calculate_bounds { +# -------------------------------------------------- +# Find out how much space all the text is going to +# occupy. This function will determine how large the +# image will be. +# + my $self = shift; + my $display_chars = $self->init_chars( @_ ) or return; + + my $my = 0; + my $mx = 0; + + for my $char_rec ( @$display_chars ) { + my ( $vx, $vy ) = $self->calculate_char_bounds( $char_rec ); + $mx += $vx; + $my < $vy and $my = $vy; + } + + return ( $mx, $my ) +} + +sub image_type { +# -------------------------------------------------- +# Returns the image type of the output format favoured +# by GD +# + my $self = shift; + my $keyimage = $self->init_image or return; + +# If the image type has not been predeclared, +# attempt to + unless ( defined $self->{image_type} ) { + $self->{image_type} ||= + UNIVERSAL::can( $keyimage, 'png' ) ? 'png' : + UNIVERSAL::can( $keyimage, 'gif' ) ? 'gif' : + UNIVERSAL::can( $keyimage, 'jpeg' ) ? 'jpeg' : + $self->warn( 'IMG_TYPE_FAIL' ); + } + + return $self->{image_type}; +} + +sub image_data { +# -------------------------------------------------- +# Returns the data to the image in scalar format. Suitable +# for print +# + my $self = shift; + + my $keyimage = $self->init_image or return; + my $image_type = $self->image_type or return; + + $self->draw_image or return; + + local $@; + my $data; + + eval { $data = $keyimage->$image_type() }; + + $@ and return $self->warn( IMG_DATA_FAIL => "$@" ); # copy value + + return $data; +} + +1; +__END__ + +=head1 NAME + +GT::Image::Security - Using the GD module, creates an image with text. + +=head1 SYNOPSIS + + use GT::Image::Security; + + my $sec_image = GT::Image::Security->new( + fonts_path => "/home/aki/public_html/fonts", + text => "Hello World" + ) or die $GT::Image::Security::error; + + # some versions have gif, others png + my $img_type = $sec_image->image_type(); + + print "Content-type: image/$img_type\n\n"; + print $sec_image->image_data; + +=head1 DESCRIPTION + +Creates an image with specified text with mild alterations to rendered text +and background to reduce machine legibility. Whenever it can, it will attempt +to use TrueType fonts as the internal fonts tend to be difficult to read +and very limited in the number of transformations possible. + +=head1 INTERFACE + +=head2 new + +Creates a new security image handler with all options populated but does +not initialize the image. While most option are set by default or automatically, +certain behaviours can be forced quite easily by passing in a new value. + +new will return undef if the GD module cannot be loaded. The exact details of the +error can be retreived from $GT::Image::Security::error or through the normal +GT::Base error function mechanism. + +The following is a list of attributes that can be used to customize the output. + +=over 4 + +=item text + +Required. The string to be rendered in the image. + +=item fonts_path + +Optional. Required only if TrueType support is desired, it should be the path to the directory that holds .TTF files. + +=item height + +Optional. Typically automatically calculated, setting this will force the image to the specified height. (Output will be clipped if not tall enough) + +=item width + +Optional. Typically automatically calculated, setting this will force the image to the specified width. (Output will be clipped if not wide enough) + +=item image_type + +Optional. Set to png/jpeg/gif if the output format is important. If GD does not support the rendering method for the type of image, image_data will return undef and an error will be set. + +=item exclude_fonts + +Optional. Arrayref of filenames to ignore when scanning fonts for reasons such as illegibility. By default, the settings have been configured to work with the Bitstream Vera selection of fonts. + +=item colour_steps + +Optional. The number of steps between 0..255 in relation to the brightness of a single colour channel. By default, it has been set to 5 as older GD modules only support 256 colours. + +=item invert + +Optional. Typically automatically chosen, it will invert the colour selections so instead of dark colours for the foreground, brighter colours will be chosen instead. Similarly for the background, from bright, dark colours will be chosen instead. + +=item max_x_wobble + +Optional. Maximum number of pixels to randomly offset characters from ideal position along the horizontal axis. + +=item max_y_wobble + +Optional. Maximum number of pixels to randomly offset characters from ideal position along the vertical axis. + +=item max_ang_wobble + +Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random angular rotation for each character in the text. + +=item base_pt + +Optional. Only affects TrueType fonts, internal fonts will not use this feature. This sets the base point size of the font. + +=item max_pt_wobble + +Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random deviation from the base_pt size for each chacter rendered. + +=item max_obfuscates + +Optional. Usually set automatically, this sets the number of times the obfuscate_image action will be called uon the image. The action randomly draws a line or a rectangle on the image to provide chaff for any attempt to use OCR type software to extract the text from the image. + +=item padding + +Optional. The amount of extra pixel space that should be around the text. + +=item display_chars + +Optional. Typically shouldn't be used. However, it may be useful in situations where you would like to reproduce the image. After image_data has been called, squirrel away the value of $obj->{display_chars} and it will contain all the settings to be able to regenerate the image's core parts. Note: it does not store colour information so while the positions and size of the image would be the same, the colours would be different. + +=back + +=head2 image_type + +Returns the type of image the module will attempt to produce. The results +can be "png", "gif", and "jpeg", fit for inserting into a mimetype header. + +If an error occurs in the testing or no rendering methods could be found, +the function will return undef. The details on the error can be retrieved +through $obj->error + +=head2 image_data + +Returns a scalar with binary data which comprise the image. The image type +can be preset via the "image_type" attribute or accertained by the +image_type() method. + +If an error occurs in the testing or no rendering methods could be found, +the function will return undef. The details on the error can be retrieved +through $obj->error + +=head1 SEE ALSO + +GD, http://stein.cshl.org/WWW/software/GD/ + +=head1 MAINTAINER + +Aki Mimoto + + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com + +=head1 VERSION + +Revision: $Id: Security.pm,v 1.3 2006/11/03 18:55:35 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Image/Size.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Image/Size.pm new file mode 100644 index 0000000..df10ba1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Image/Size.pm @@ -0,0 +1,1076 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Image::Size +# Author: via CPAN (see POD) +# Revision: $Id: Size.pm,v 1.5 2008/10/17 16:29:21 brewt Exp $ +# Based off: Image::Size, 3.0.1 +# +# ================================================================== +# +# This module is used to determine the size of a file, and is based on +# Image::Size (available at CPAN) version 3.0.1. It's been hacked up +# a little to use GT::AutoLoader instead of AutoLoader. It also had to +# be changed to _not_ use File::Spec, since that wasn't standard in +# Perl 5.004_04. Image::Magick and support for compressed ShockWave/Flash +# MX files have also been removed. +# +# Image/Size.pm had the following header: +# +############################################################################### +# +# This file copyright (c) 2000 by Randy J. Ray, all rights reserved +# +# Copying and distribution are permitted under the terms of the Artistic +# License as distributed with Perl versions 5.005 and later. +# +############################################################################### +# +# Once upon a time, this code was lifted almost verbatim from wwwis by Alex +# Knowles, alex@ed.ac.uk. Since then, even I barely recognize it. It has +# contributions, fixes, additions and enhancements from all over the world. +# +# See the file README [of the Image-Size package on CPAN] for change history. +# +############################################################################### + +package GT::Image::Size; + +require 5.002; + +use strict; +use Cwd (); +use Symbol (); +use GT::AutoLoader; +require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $revision $VERSION $NO_CACHE + $GIF_BEHAVIOR %PCD_MAP $PCD_SCALE $read_in $last_pos); + +@ISA = qw(Exporter); +@EXPORT = qw(imgsize); +@EXPORT_OK = qw(imgsize html_imgsize attr_imgsize $NO_CACHE $PCD_SCALE $GIF_BEHAVIOR); +%EXPORT_TAGS = ('all' => [ @EXPORT_OK ]); + +$revision = q$Id: Size.pm,v 1.5 2008/10/17 16:29:21 brewt Exp $; +$VERSION = "2.99"; + +# Default behavior for GIFs is to return the "screen" size +$GIF_BEHAVIOR = 0; + +# This allows people to specifically request that the cache not be used +$NO_CACHE = 0; + +# Package lexicals - invisible to outside world, used only in imgsize +# +# Cache of files seen, and mapping of patterns to the sizing routine +my %cache = (); +my %type_map = ( '^GIF8[7,9]a' => \&gifsize, + "^\xFF\xD8" => \&jpegsize, + "^\x89PNG\x0d\x0a\x1a\x0a" => \&pngsize, + "^P[1-7]" => \&ppmsize, # also XVpics + '\#define\s+\S+\s+\d+' => \&xbmsize, + '\/\* XPM \*\/' => \&xpmsize, + '^MM\x00\x2a' => \&tiffsize, + '^II\x2a\x00' => \&tiffsize, + '^BM' => \&bmpsize, + '^8BPS' => \&psdsize, + '^PCD_OPA' => \&pcdsize, + '^FWS' => \&swfsize, + "^\x8aMNG\x0d\x0a\x1a\x0a" => \&mngsize); +# Kodak photo-CDs are weird. Don't ask me why, you really don't want details. +%PCD_MAP = ( 'base/16' => [ 192, 128 ], + 'base/4' => [ 384, 256 ], + 'base' => [ 768, 512 ], + 'base4' => [ 1536, 1024 ], + 'base16' => [ 3072, 2048 ], + 'base64' => [ 6144, 4096 ] ); +# Default scale for PCD images +$PCD_SCALE = 'base'; + +# +# These are lexically-scoped anonymous subroutines for reading the three +# types of input streams. When the input to imgsize() is typed, then the +# lexical "read_in" is assigned one of these, thus allowing the individual +# routines to operate on these streams abstractly. +# + +my $read_io = sub { + my $handle = shift; + my ($length, $offset) = @_; + + if (defined($offset) && ($offset != $last_pos)) + { + $last_pos = $offset; + return '' if (! seek($handle, $offset, 0)); + } + + my ($data, $rtn) = ('', 0); + $rtn = read $handle, $data, $length; + $data = '' unless ($rtn); + $last_pos = tell $handle; + + $data; +}; + +my $read_buf = sub { + my $buf = shift; + my ($length, $offset) = @_; + + if (defined($offset) && ($offset != $last_pos)) + { + $last_pos = $offset; + return '' if ($last_pos > length($$buf)); + } + + my $data = substr($$buf, $last_pos, $length); + $last_pos += length($data); + + $data; +}; + +sub imgsize +{ + my $stream = shift; + + my ($handle, $header); + my ($x, $y, $id, $mtime, @list); + # These only used if $stream is an existant open FH + my ($save_pos, $need_restore) = (0, 0); + # This is for when $stream is a locally-opened file + my $need_close = 0; + # This will contain the file name, if we got one + my $file_name = undef; + + $header = ''; + + if (ref($stream) eq "SCALAR") + { + $handle = $stream; + $read_in = $read_buf; + $header = substr(($$handle || ''), 0, 256); + } + elsif (ref $stream) + { + # + # I no longer require $stream to be in the IO::* space. So I'm assuming + # you don't hose yourself by passing a ref that can't do fileops. If + # you do, you fix it. + # + $handle = $stream; + $read_in = $read_io; + $save_pos = tell $handle; + $need_restore = 1; + + # + # First alteration (didn't wait long, did I?) to the existant handle: + # + # assist dain-bramaged operating systems -- SWD + # SWD: I'm a bit uncomfortable with changing the mode on a file + # that something else "owns" ... the change is global, and there + # is no way to reverse it. + # But image files ought to be handled as binary anyway. + # + binmode($handle); + seek($handle, 0, 0); + read $handle, $header, 256; + seek($handle, 0, 0); + } + else + { + unless ($NO_CACHE) + { + $stream = Cwd::cwd() . '/' . $stream + unless $stream =~ m{^(?:[a-zA-Z]:)?[\\/]}; + $mtime = (stat $stream)[9]; + if (-e "$stream" and exists $cache{$stream}) + { + @list = split(/,/, $cache{$stream}, 4); + + # Don't return the cache if the file is newer. + return @list[1 .. 3] unless ($list[0] < $mtime); + # In fact, clear it + delete $cache{$stream}; + } + } + + #first try to open the stream + $handle = Symbol::gensym(); + open($handle, "< $stream") or + return (undef, undef, "Can't open image file $stream: $!"); + + $need_close = 1; + # assist dain-bramaged operating systems -- SWD + binmode($handle); + read $handle, $header, 256; + seek($handle, 0, 0); + $read_in = $read_io; + $file_name = $stream; + } + $last_pos = 0; + + # + # Oh pessimism... set the values of $x and $y to the error condition. If + # the grep() below matches the data to one of the known types, then the + # called subroutine will override these... + # + $id = "Data stream is not a known image file format"; + $x = undef; + $y = undef; + + grep($header =~ /$_/ && (($x, $y, $id) = &{$type_map{$_}}($handle)), + keys %type_map); + + # + # Added as an afterthought: I'm probably not the only one who uses the + # same shaded-sphere image for several items on a bulleted list: + # + $cache{$stream} = join(',', $mtime, $x, $y, $id) + unless ($NO_CACHE or (ref $stream) or (! defined $x)); + + # + # If we were passed an existant file handle, we need to restore the + # old filepos: + # + seek($handle, $save_pos, 0) if $need_restore; + # ...and if we opened the file ourselves, we need to close it + close($handle) if $need_close; + + # results: + return (wantarray) ? ($x, $y, $id) : (); +} + +sub html_imgsize +{ + my @args = imgsize(@_); + + # Use lowercase and quotes so that it works with xhtml. + return ((defined $args[0]) ? + sprintf('width="%d" height="%d"', @args) : + undef); +} + +sub attr_imgsize +{ + my @args = imgsize(@_); + + return ((defined $args[0]) ? + (('-width', '-height', @args)[0, 2, 1, 3]) : + undef); +} + +# This used only in gifsize: +sub img_eof +{ + my $stream = shift; + + return ($last_pos >= length($$stream)) if (ref($stream) eq "SCALAR"); + + eof $stream; +} + +# Simple converter-routine used by SWF and CWS code +sub _bin2int { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } + +# +# Autoloaded subroutines below this point +# + +########################################################################### +# Subroutine gets the size of the specified GIF +########################################################################### +$COMPILE{gifsize} = __LINE__ . <<'END_OF_SUB'; +sub gifsize { + my $stream = shift; + + my ($cmapsize, $buf, $sh, $sw, $h, $w, $x, $y, $type); + + my $gif_blockskip = sub { + my ($skip, $type) = @_; + my ($lbuf); + + &$read_in($stream, $skip); # Skip header (if any) + while (1) + { + if (&img_eof($stream)) + { + return (undef, undef, + "Invalid/Corrupted GIF (at EOF in GIF $type)"); + } + $lbuf = &$read_in($stream, 1); # Block size + last if ord($lbuf) == 0; # Block terminator + &$read_in($stream, ord($lbuf)); # Skip data + } + }; + + return (undef, undef, + 'Out-of-range value for $GT::Image::Size::GIF_BEHAVIOR: ' . + $GT::Image::Size::GIF_BEHAVIOR) + if ($GT::Image::Size::GIF_BEHAVIOR > 2); + + # Skip over the identifying string, since we already know this is a GIF + $type = &$read_in($stream, 6); + if (length($buf = &$read_in($stream, 7)) != 7 ) + { + return (undef, undef, "Invalid/Corrupted GIF (bad header)"); + } + ($sw, $sh, $x) = unpack("vv C", $buf); + if ($GT::Image::Size::GIF_BEHAVIOR == 0) + { + return ($sw, $sh, 'GIF'); + } + + if ($x & 0x80) + { + $cmapsize = 3 * (2**(($x & 0x07) + 1)); + if (! &$read_in($stream, $cmapsize)) + { + return (undef, undef, + "Invalid/Corrupted GIF (global color map too small?)"); + } + } + + # Before we start this loop, set $sw and $sh to 0s and use them to track + # the largest sub-image in the overall GIF. + $sw = $sh = 0; + + FINDIMAGE: + while (1) + { + if (&img_eof($stream)) + { + # At this point, if we haven't returned then the user wants the + # largest of the sub-images. So, if $sh and $sw are still 0s, then + # we didn't see even one Image Descriptor block. Otherwise, return + # those two values. + if ($sw and $sh) + { + return ($sw, $sh, 'GIF'); + } + else + { + return (undef, undef, + "Invalid/Corrupted GIF (no Image Descriptors)"); + } + } + $buf = &$read_in($stream, 1); + ($x) = unpack("C", $buf); + if ($x == 0x2c) + { + # Image Descriptor (GIF87a, GIF89a 20.c.i) + if (length($buf = &$read_in($stream, 8)) != 8) + { + return (undef, undef, + "Invalid/Corrupted GIF (missing image header?)"); + } + ($x, $y) = unpack("x4 vv", $buf); + return ($x, $y, 'GIF') if ($GT::Image::Size::GIF_BEHAVIOR == 1); + if ($x > $sw and $y > $sh) + { + $sw = $x; + $sh = $y; + } + } + if ($x == 0x21) + { + # Extension Introducer (GIF89a 23.c.i, could also be in GIF87a) + $buf = &$read_in($stream, 1); + ($x) = unpack("C", $buf); + if ($x == 0xF9) + { + # Graphic Control Extension (GIF89a 23.c.ii) + &$read_in($stream, 6); # Skip it + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0xFE) + { + # Comment Extension (GIF89a 24.c.ii) + &$gif_blockskip(0, "Comment"); + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0x01) + { + # Plain Text Label (GIF89a 25.c.ii) + &$gif_blockskip(13, "text data"); + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0xFF) + { + # Application Extension Label (GIF89a 26.c.ii) + &$gif_blockskip(12, "application data"); + next FINDIMAGE; # Look again for Image Descriptor + } + else + { + return (undef, undef, + sprintf("Invalid/Corrupted GIF (Unknown " . + "extension %#x)", $x)); + } + } + else + { + return (undef, undef, + sprintf("Invalid/Corrupted GIF (Unknown code %#x)", + $x)); + } + } +} +END_OF_SUB + +$COMPILE{xbmsize} = __LINE__ . <<'END_OF_SUB'; +sub xbmsize { + my $stream = shift; + + my $input; + my ($x, $y, $id) = (undef, undef, "Could not determine XBM size"); + + $input = &$read_in($stream, 1024); + if ($input =~ /^\#define\s*\S*\s*(\d+)\s*\n\#define\s*\S*\s*(\d+)/si) + { + ($x, $y) = ($1, $2); + $id = 'XBM'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# Added by Randy J. Ray, 30 Jul 1996 +# Size an XPM file by looking for the "X Y N W" line, where X and Y are +# dimensions, N is the total number of colors defined, and W is the width of +# a color in the ASCII representation, in characters. We only care about X & Y. +$COMPILE{xpmsize} = __LINE__ . <<'END_OF_SUB'; +sub xpmsize { + my $stream = shift; + + my $line; + my ($x, $y, $id) = (undef, undef, "Could not determine XPM size"); + + while ($line = &$read_in($stream, 1024)) + { + next unless ($line =~ /"\s*(\d+)\s+(\d+)(\s+\d+\s+\d+){1,2}\s*"/s); + ($x, $y) = ($1, $2); + $id = 'XPM'; + last; + } + + ($x, $y, $id); +} +END_OF_SUB + + +# pngsize : gets the width & height (in pixels) of a png file +# cor this program is on the cutting edge of technology! (pity it's blunt!) +# +# Re-written and tested by tmetro@vl.com +$COMPILE{pngsize} = __LINE__ . <<'END_OF_SUB'; +sub pngsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "could not determine PNG size"); + my ($offset, $length); + + # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1 + $offset = 12; $length = 4; + if (&$read_in($stream, $length, $offset) eq 'IHDR') + { + # IHDR = Image Header + $length = 8; + ($x, $y) = unpack("NN", &$read_in($stream, $length)); + $id = 'PNG'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# mngsize: gets the width and height (in pixels) of an MNG file. +# See for the specification. +# +# Basically a copy of pngsize. +$COMPILE{mngsize} = __LINE__ . <<'END_OF_SUB'; +sub mngsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "could not determine MNG size"); + my ($offset, $length); + + # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1 + $offset = 12; $length = 4; + if (&$read_in($stream, $length, $offset) eq 'MHDR') + { + # MHDR = Image Header + $length = 8; + ($x, $y) = unpack("NN", &$read_in($stream, $length)); + $id = 'MNG'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# jpegsize: gets the width and height (in pixels) of a jpeg file +# Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995 +# modified slightly by alex@ed.ac.uk +# and further still by rjray@blackperl.com +# optimization and general re-write from tmetro@vl.com +$COMPILE{jpegsize} = __LINE__ . <<'END_OF_SUB'; +sub jpegsize { + my $stream = shift; + + my $MARKER = "\xFF"; # Section marker. + + my $SIZE_FIRST = 0xC0; # Range of segment identifier codes + my $SIZE_LAST = 0xC3; # that hold size info. + + my ($x, $y, $id) = (undef, undef, "could not determine JPEG size"); + + my ($marker, $code, $length); + my $segheader; + + # Dummy read to skip header ID + &$read_in($stream, 2); + while (1) + { + $length = 4; + $segheader = &$read_in($stream, $length); + + # Extract the segment header. + ($marker, $code, $length) = unpack("a a n", $segheader); + + # Verify that it's a valid segment. + if ($marker ne $MARKER) + { + # Was it there? + $id = "JPEG marker not found"; + last; + } + elsif ((ord($code) >= $SIZE_FIRST) && (ord($code) <= $SIZE_LAST)) + { + # Segments that contain size info + $length = 5; + ($y, $x) = unpack("xnn", &$read_in($stream, $length)); + $id = 'JPG'; + last; + } + else + { + # Dummy read to skip over data + &$read_in($stream, ($length - 2)); + } + } + + ($x, $y, $id); +} +END_OF_SUB + +# ppmsize: gets data on the PPM/PGM/PBM family. +# +# Contributed by Carsten Dominik +$COMPILE{ppmsize} = __LINE__ . <<'END_OF_SUB'; +sub ppmsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, + "Unable to determine size of PPM/PGM/PBM data"); + my $n; + + my $header = &$read_in($stream, 1024); + + # PPM file of some sort + $header =~ s/^\#.*//mg; + ($n, $x, $y) = ($header =~ /^(P[1-6])\s+(\d+)\s+(\d+)/s); + $id = "PBM" if $n eq "P1" || $n eq "P4"; + $id = "PGM" if $n eq "P2" || $n eq "P5"; + $id = "PPM" if $n eq "P3" || $n eq "P6"; + if ($n eq 'P7') + { + # John Bradley's XV thumbnail pics (thanks to inwap@jomis.Tymnet.COM) + $id = 'XV'; + ($x, $y) = ($header =~ /IMGINFO:(\d+)x(\d+)/s); + } + + ($x, $y, $id); +} +END_OF_SUB + +# tiffsize: size a TIFF image +# +# Contributed by Cloyce Spradling +$COMPILE{tiffsize} = __LINE__ . <<'END_OF_SUB'; +sub tiffsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of TIFF data"); + + my $endian = 'n'; # Default to big-endian; I like it better + my $header = &$read_in($stream, 4); + $endian = 'v' if ($header =~ /II\x2a\x00/o); # little-endian + + # Set up an association between data types and their corresponding + # pack/unpack specification. Don't take any special pains to deal with + # signed numbers; treat them as unsigned because none of the image + # dimensions should ever be negative. (I hope.) + my @packspec = ( undef, # nothing (shouldn't happen) + 'C', # BYTE (8-bit unsigned integer) + undef, # ASCII + $endian, # SHORT (16-bit unsigned integer) + uc($endian), # LONG (32-bit unsigned integer) + undef, # RATIONAL + 'c', # SBYTE (8-bit signed integer) + undef, # UNDEFINED + $endian, # SSHORT (16-bit unsigned integer) + uc($endian), # SLONG (32-bit unsigned integer) + ); + + my $offset = &$read_in($stream, 4, 4); # Get offset to IFD + $offset = unpack(uc($endian), $offset); # Fix it so we can use it + + my $ifd = &$read_in($stream, 2, $offset); # Get number of directory entries + my $num_dirent = unpack($endian, $ifd); # Make it useful + $offset += 2; + $num_dirent = $offset + ($num_dirent * 12); # Calc. maximum offset of IFD + + # Do all the work + $ifd = ''; + my $tag = 0; + my $type = 0; + while (!defined($x) || !defined($y)) { + $ifd = &$read_in($stream, 12, $offset); # Get first directory entry + last if (($ifd eq '') || ($offset > $num_dirent)); + $offset += 12; + $tag = unpack($endian, $ifd); # ...and decode its tag + $type = unpack($endian, substr($ifd, 2, 2)); # ...and the data type + # Check the type for sanity. + next if (($type > @packspec+0) || (!defined($packspec[$type]))); + if ($tag == 0x0100) { # ImageWidth (x) + # Decode the value + $x = unpack($packspec[$type], substr($ifd, 8, 4)); + } elsif ($tag == 0x0101) { # ImageLength (y) + # Decode the value + $y = unpack($packspec[$type], substr($ifd, 8, 4)); + } + } + + # Decide if we were successful or not + if (defined($x) && defined($y)) { + $id = 'TIF'; + } else { + $id = ''; + $id = 'ImageWidth ' if (!defined($x)); + if (!defined ($y)) { + $id .= 'and ' if ($id ne ''); + $id .= 'ImageLength '; + } + $id .= 'tag(s) could not be found'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# bmpsize: size a Windows-ish BitMaP image +# +# Adapted from code contributed by Aldo Calpini +$COMPILE{bmpsize} = __LINE__ . <<'END_OF_SUB'; +sub bmpsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of BMP data"); + my ($buffer); + + $buffer = &$read_in($stream, 26); + ($x, $y) = unpack("x18VV", $buffer); + $id = 'BMP' if (defined $x and defined $y); + + ($x, $y, $id); +} +END_OF_SUB + +# psdsize: determine the size of a PhotoShop save-file (*.PSD) +$COMPILE{psdsize} = __LINE__ . <<'END_OF_SUB'; +sub psdsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of PSD data"); + my ($buffer); + + $buffer = &$read_in($stream, 26); + ($y, $x) = unpack("x14NN", $buffer); + $id = 'PSD' if (defined $x and defined $y); + + ($x, $y, $id); +} +END_OF_SUB + +# swfsize: determine size of ShockWave/Flash files. Adapted from code sent by +# Dmitry Dorofeev +$COMPILE{swfsize} = __LINE__ . <<'END_OF_SUB'; +sub swfsize { + my $image = shift; + my $header = &$read_in($image, 33); + + my $ver = _bin2int(unpack 'B8', substr($header, 3, 1)); + my $bs = unpack 'B133', substr($header, 8, 17); + my $bits = _bin2int(substr($bs, 0, 5)); + my $x = int(_bin2int(substr($bs, 5+$bits, $bits))/20); + my $y = int(_bin2int(substr($bs, 5+$bits*3, $bits))/20); + + return ($x, $y, 'SWF'); +} +END_OF_SUB + +# Suggested by Matt Mueller , and based on a piece of +# sample Perl code by a currently-unknown author. Credit will be placed here +# once the name is determined. +$COMPILE{pcdsize} = __LINE__ . <<'END_OF_SUB'; +sub pcdsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of PCD data"); + my $buffer = &$read_in($stream, 0xf00); + + # Second-tier sanity check + return ($x, $y, $id) unless (substr($buffer, 0x800, 3) eq 'PCD'); + + my $orient = ord(substr($buffer, 0x0e02, 1)) & 1; # Clear down to one bit + ($x, $y) = @{$GT::Image::Size::PCD_MAP{lc $GT::Image::Size::PCD_SCALE}} + [($orient ? (0, 1) : (1, 0))]; + + return ($x, $y, 'PCD'); +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::Image::Size - read the dimensions of an image in several popular formats + +=head1 SYNOPSIS + + use GT::Image::Size; + # Get the size of globe.gif + ($globe_x, $globe_y) = imgsize("globe.gif"); + # Assume X=60 and Y=40 for remaining examples + + use GT::Image::Size 'html_imgsize'; + # Get the size as 'width="X" height="Y"' for HTML generation + $size = html_imgsize("globe.gif"); + # $size == 'width="60" height="40"' + + use GT::Image::Size 'attr_imgsize'; + # Get the size as a list passable to routines in CGI.pm + @attrs = attr_imgsize("globe.gif"); + # @attrs == ('-width', 60, '-height', 40) + + use GT::Image::Size; + # Get the size of an in-memory buffer + ($buf_x, $buf_y) = imgsize(\$buf); + # Assuming that $buf was the data, imgsize() needed a reference to a scalar + +=head1 DESCRIPTION + +The B library is based upon the C script written by +Alex Knowles I<(alex@ed.ac.uk)>, a tool to examine HTML and add 'width' and +'height' parameters to image tags. The sizes are cached internally based on +file name, so multiple calls on the same file name (such as images used +in bulleted lists, for example) do not result in repeated computations. + +B provides three interfaces for possible import: + +=over + +=item imgsize(I) + +Returns a three-item list of the X and Y dimensions (width and height, in +that order) and image type of I. Errors are noted by undefined +(B) values for the first two elements, and an error string in the third. +The third element can be (and usually is) ignored, but is useful when +sizing data whose type is unknown. + +=item html_imgsize(I) + +Returns the width and height (X and Y) of I pre-formatted as a single +string C<'width="X" height="Y"'> suitable for addition into generated HTML IMG +tags. If the underlying call to C fails, B is returned. The +format returned is dually suited to both HTML and XHTML. + +=item attr_imgsize(I) + +Returns the width and height of I as part of a 4-element list useful +for routines that use hash tables for the manipulation of named parameters, +such as the Tk or CGI libraries. A typical return value looks like +C<("-width", X, "-height", Y)>. If the underlying call to C fails, +B is returned. + +=back + +By default, only C is exported. Any one or combination of the three +may be explicitly imported, or all three may be with the tag B<:all>. + +=head2 Input Types + +The sort of data passed as I can be one of three forms: + +=over + +=item string + +If an ordinary scalar (string) is passed, it is assumed to be a file name +(either absolute or relative to the current working directory of the +process) and is searched for and opened (if found) as the source of data. +Possible error messages (see DIAGNOSTICS below) may include file-access +problems. + +=item scalar reference + +If the passed-in stream is a scalar reference, it is interpreted as pointing +to an in-memory buffer containing the image data. + + # Assume that &read_data gets data somewhere (WWW, etc.) + $img = &read_data; + ($x, $y, $id) = imgsize(\$img); + # $x and $y are dimensions, $id is the type of the image + +=item Open file handle + +The third option is to pass in an open filehandle (such as an object of +the C class, for example) that has already been associated with +the target image file. The file pointer will necessarily move, but will be +restored to its original position before subroutine end. + + # $fh was passed in, is IO::File reference: + ($x, $y, $id) = imgsize($fh); + # Same as calling with filename, but more abstract. + +=back + +=head2 Recognized Formats + +GT::Image::Size natively understands and sizes data in the following formats: + +=over 4 + +=item GIF + +=item JPG + +=item XBM + +=item XPM + +=item PPM family (PPM/PGM/PBM) + +=item XV thumbnails + +=item PNG + +=item MNG + +=item TIF + +=item BMP + +=item PSD (Adobe PhotoShop) + +=item SWF (ShockWave/Flash) + +=item PCD (Kodak PhotoCD, see notes below) + +=back + +When using the C interface, there is a third, unused value returned +if the programmer wishes to save and examine it. This value is the identity of +the data type, expressed as a 2-3 letter abbreviation as listed above. This is +useful when operating on open file handles or in-memory data, where the type +is as unknown as the size. The two support routines ignore this third return +value, so those wishing to use it must use the base C routine. + +=head2 Information Cacheing and C<$NO_CACHE> + +When a filename is passed to any of the sizing routines, the default behavior +of the library is to cache the resulting information. The modification-time of +the file is also recorded, to determine whether the cache should be purged and +updated. This was originally added due to the fact that a number of CGI +applications were using this library to generate attributes for pages that +often used the same graphical element many times over. + +However, the cacheing can lead to problems when the files are generated +dynamically, at a rate that exceeds the resolution of the modification-time +value on the filesystem. Thus, the optionally-importable control variable +C<$NO_CACHE> has been introduced. If this value is anything that evaluates to a +non-false value (be that the value 1, any non-null string, etc.) then the +cacheing is disabled until such time as the program re-enables it by setting +the value to false. + +The parameter C<$NO_CACHE> may be imported as with the B routine, and +is also imported when using the import tag B>. If the programmer +chooses not to import it, it is still accessible by the fully-qualified package +name, B<$GT::Image::Size::NO_CACHE>. + +=head2 Sizing PhotoCD Images + +With version 2.95, support for the Kodak PhotoCD image format is +included. However, these image files are not quite like the others. One file +is the source of the image in any of a range of pre-set resolutions (all with +the same aspect ratio). Supporting this here is tricky, since there is nothing +inherent in the file to limit it to a specific resolution. + +The library addresses this by using a scale mapping, and requiring the user +(you) to specify which scale is preferred for return. Like the C<$NO_CACHE> +setting described earlier, this is an importable scalar variable that may be +used within the application that uses B. This parameter is called +C<$PCD_SCALE>, and is imported by the same name. It, too, is also imported +when using the tag B> or may be referenced as +B<$GT::Image::Size::PCD_SCALE>. + +The parameter should be set to one of the following values: + + base/16 + base/4 + base + base4 + base16 + base64 + +Note that not all PhotoCD disks will have included the C +resolution. The actual resolutions are not listed here, as they are constant +and can be found in any documentation on the PCD format. The value of +C<$PCD_SCALE> is treated in a case-insensitive manner, so C is the same +as C or C. The default scale is set to C. + +Also note that the library makes no effort to read enough of the PCD file to +verify that the requested resolution is available. The point of this library +is to read as little as necessary so as to operate efficiently. Thus, the only +real difference to be found is in whether the orientation of the image is +portrait or landscape. That is in fact all that the library extracts from the +image file. + +=head2 Controlling Behavior with GIF Images + +GIF images present a sort of unusual situation when it comes to reading size. +Because GIFs can be a series of sub-images to be isplayed as an animated +sequence, what part does the user want to get the size for? + +When dealing with GIF files, the user may control the behavior by setting the +global value B<$Image::Size::GIF_BEHAVIOR>. Like the PCD setting, this may +be imported when loading the library. Three values are recognized by the +GIF-handling code: + +=over 4 + +=item 0 + +This is the default value. When this value is chosen, the returned dimensions +are those of the "screen". The "screen" is the display area that the GIF +declares in the first data block of the file. No sub-images will be greater +than this in size; if they are, the specification dictates that they be +cropped to fit within the box. + +This is also the fastest method for sizing the GIF, as it reads the least +amount of data from the image stream. + +=item 1 + +If this value is set, then the size of the first sub-image within the GIF is +returned. For plain (non-animated) GIF files, this would be the same as the +screen (though it doesn't have to be, strictly-speaking). + +When the first image descriptor block is read, the code immediately returns, +making this only slightly-less efficient than the previous setting. + +=item 2 + +If this value is chosen, then the code loops through all the sub-images of the +animated GIF, and returns the dimensions of the largest of them. + +This option requires that the full GIF image be read, in order to ensure that +the largest is found. + +=back + +Any value outside this range will produce an error in the GIF code before any +image data is read. + +The value of dimensions other than the view-port ("screen") is dubious. +However, some users have asked for that functionality. + +=head1 DIAGNOSTICS + +The base routine, C, returns B as the first value in its list +when an error has occurred. The third element contains a descriptive +error message. + +The other two routines simply return B in the case of error. + +=head1 MORE EXAMPLES + +The B interface is also well-suited to use with the Tk +extension: + + $image = $widget->Photo(-file => $img_path, attr_imgsize($img_path)); + +Since the C classes use dashed option names as C does, no +further translation is needed. + +This package is also well-suited for use within an Apache web server context. +File sizes are cached upon read (with a check against the modified time of +the file, in case of changes), a useful feature for a B environment +in which a child process endures beyond the lifetime of a single request. +Other aspects of the B environment cooperate nicely with this +module, such as the ability to use a sub-request to fetch the full pathname +for a file within the server space. This complements the HTML generation +capabilities of the B module, in which C wants a URL but +C needs a file path: + + # Assume $Q is an object of class CGI, $r is an Apache request object. + # $imgpath is a URL for something like "/img/redball.gif". + $r->print($Q->img({ -src => $imgpath, + attr_imgsize($r->lookup_uri($imgpath)->filename) })); + +The advantage here, besides not having to hard-code the server document root, +is that Apache passes the sub-request through the usual request lifecycle, +including any stages that would re-write the URL or otherwise modify it. + +=head1 CAVEATS + +Caching of size data can only be done on inputs that are file names. Open +file handles and scalar references cannot be reliably transformed into a +unique key for the table of cache data. Buffers could be cached using the +MD5 module, and perhaps in the future I will make that an option. I do not, +however, wish to lengthen the dependancy list by another item at this time. + +=head1 SEE ALSO + +C for a description of C +and how to obtain it. + +=head1 AUTHORS + +Perl module interface by Randy J. Ray I<(rjray@blackperl.com)>, original +image-sizing code by Alex Knowles I<(alex@ed.ac.uk)> and Andrew Tong +I<(werdna@ugcs.caltech.edu)>, used with their joint permission. + +Some bug fixes submitted by Bernd Leibing I<(bernd.leibing@rz.uni-ulm.de)>. +PPM/PGM/PBM sizing code contributed by Carsten Dominik +I<(dominik@strw.LeidenUniv.nl)>. Tom Metro I<(tmetro@vl.com)> re-wrote the JPG +and PNG code, and also provided a PNG image for the test suite. Dan Klein +I<(dvk@lonewolf.com)> contributed a re-write of the GIF code. Cloyce Spradling +I<(cloyce@headgear.org)> contributed TIFF sizing code and test images. Aldo +Calpini I<(a.calpini@romagiubileo.it)> suggested support of BMP images (which +I I should have already thought of :-) and provided code to work +with. A patch to allow html_imgsize to produce valid output for XHTML, as +well as some documentation fixes was provided by Charles Levert +I<(charles@comm.polymtl.ca)>. The ShockWave/Flash support was provided by +Dmitry Dorofeev I<(dima@yasp.com)>. Though I neglected to take note of who +supplied the PSD (PhotoShop) code, a bug was identified by Alex Weslowski +, who also provided a test image. PCD support +was adapted from a script made available by Phil Greenspun, as guided to my +attention by Matt Mueller I. A thorough read of the +documentation and source by Philip Newton I +found several typos and a small buglet. Ville Skyttä I<(ville.skytta@iki.fi)> +provided the MNG and the Image::Magick fallback code. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.cn b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.cn new file mode 100644 index 0000000..bdaa192 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.cn @@ -0,0 +1,369 @@ + +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s ¤£¯àªÅ¥Õ¡C", + ERR_PATH => "¥»¸ô®| (%s) ¤£¦b¨t²Î¤W", + ERR_PATHWRITE => "µLªk¼g¤J¥Ø¿ý (%s)¡C­ì¦]¡G (%s)", + ERR_PATHCREATE => "µLªk«Ø¥ß¥Ø¿ý (%s)¡C­ì¦]¡G (%s)", + ERR_URLFMT => "(%s) ¦ü¥G¤£¬O¥¿½Tªººô§}", + ERR_FTPFMT => "(%s) ¦ü¥G¤£¬O¥¿½Tªº FTP ¦ì¸m", + ERR_EMAILFMT => "(%s) ¦ü¥G¤£¬O¥¿½Tªº email", + ERR_SENDMAIL => "¦¹¸ô®| (%s) ¤£¦s¦b¨t²Î¤W©ÎµLªk°õ¦æ", + ERR_SMTP => "(%s) ¤£¬O¦³®Äªº SMTP ¥D¾÷¦WºÙ", + ERR_PERL => "«ü¦V Perl ªº¸ô®| (%s) %s", + ERR_DIREXISTS => "%s ¦s¦b¨t²Î¤W¦ý«o¤£¬O¤@­Ó¥Ø¿ý¡AµLªk¥Î¦¹¦WºÙ«Ø¥ß¥Ø¿ý", + ERR_WRITEOPEN => "µLªk¶}±Ò %s ¨Ó¼g¤J¸ê®Æ¡F­ì¦]¡G %s", + ERR_READOPEN => "µLªk¶}±Ò %s ¨ÓŪ¥X¸ê®Æ¡F­ì¦]¡G %s", + ERR_RENAME => "µLªk±N %s ­«·s©R¦W¬° %s¡F­ì¦]¡G %s", + ERR_MKDIR => "µLªk mkdir %s¡C­ì¦]¡G %s", + ENTER_REG => '½Ð¿é¤J±zªºµù¥U¸¹½X', + REG_NUM => 'µù¥U¸¹½X', + ENTER_SENDMAIL => '½Ð¿é¤J¥Î¨Ó°e¥X¹q¶lªº sendmail ¸ô®|©Î SMTP ¥D¾÷¦WºÙ', + MAILER => 'Mailer', + ENTER_PERL => '½Ð¿é¤J«ü¦V Perl 5 ªº¸ô®|', + PATH_PERL => 'Perl ¸ô®|', + CREATE_DIRS => '«Ø¥ß¥Ø¿ý', + INSTALL_CURRUPTED => ' +install.dat ¦ü¥G¤w·lÃa¡C½Ð½T»{±z¦b FTP ¥»ÀɮɡB¨Ï¥Îªº¬O BINARY ¼Ò¦¡¡C©ÎªÌ¡A +±z¤U¸üªºÀ£ÁYÀÉ¥i¯à¤w·lÃa¡C½Ð¦A¦¸¥Ñ Gossamer Threads ¤U¸ü·sªºÀɮסC + +¦pªG±z»Ý­n¨ó§U¡A½Ð¨ì¡G + http://gossamer-threads.com/scripts/support/ +', + ADMIN_PATH_ERROR => "±z¥²¶·¿é¤J¦Ü²{¦³ª©¥»ªº admin ¸ô®|", + INTRO => ' +%s Quick Install http://gossamer-threads.com +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved +Redistribution in part or in whole strictly prohibited. + +¸Ô²Ó¸ê®Æ½Ð°Ñ¾\ LICENSE ÀÉ +', + WELCOME => ' +Åwªï¨Ï¥Î %s ¦Û°Ê¦w¸Ë¨t²Î¡C¥»¦w¸Ëµ{¦¡±N·|°õ¦æ %s ªº¸ÑÀ£ÁY°Ê§@¡B +³]©w©Ò¦³ÀÉ®×Åv­­¡B¤Î¥¿½Tªº³]©w¨ì Perl ªº¸ô®|¡C + +²Ä¤@¨B¡A½Ð¥ý¿é¤J¥H¤Uªº¸ê®Æ¡C +±z¥i¥H¦b¥ô¦ó®É­ÔÁä¤J exit ©Î quit ¨Ó¨ú®ø¦w¸Ëµ{§Ç¡C +', + IS_UPGRADE => "½Ð°Ý±z­n¶i¦æ¥þ·s¦w¸Ë©Î¬O±N²{¦³ª©¥»¤É¯Å¡H", + ENTER_ADMIN_PATH => "\n½Ð¿é¤J¦Ü²{¦³ª©¥»ªº admin ¸ô®|", + UNARCHIVING => '¸ÑÀ£ÁY¤¤', + TAR_OPEN => "µLªk¶}±Ò %s¡C­ì¦]¡G %s", + TAR_READ => "±q %s Ū¥X¸ê®Æ®Éµo¥Í¿ù»~¡CÀ³Åª¥X %s bytes¡A¦ý¥uŪ¥X %s.", + TAR_BINMODE => "µLªk binmode %s¡C­ì¦]¡G %s", + TAR_BADARGS => "µL®Ä¤Þ¼Æ¡]arguments¡^¶Ç¤J %s¡C­ì¦]¡G %s", + TAR_CHECKSUM => "¸ÑªR tar Àɮɵo¥Í Checksum ¿ù»~¡C³o­Ó tar ÀÉ«Ü¥i¯à¬O·lÃaÀɮסC\nÀÉÀY¡G %s\nChecksum¡G %s\nÀɮסG %s\n", + TAR_NOBODY => "'%s' does not have a body!", + TAR_CANTFIND => "¦b tar À£ÁYÀɸ̧䤣¨ìÀɮסG '%s' ¡C", + TAR_CHMOD => "µLªk chmod %s¡C­ì¦]¡G %s", + TAR_DIRFILE => "'%s' ¦s¦b¦Ó¥B¬O­ÓÀɮסCµLªk«Ø¥ß¥Ø¿ý", + TAR_MKDIR => "µLªk mkdir %s¡C­ì¦]¡G %s", + TAR_RENAME => "µLªk­«·s©R¦W temp ÀÉ¡G '%s' ¦Ü tar ÀÉ '%s'¡C­ì¦]¡G %s", + TAR_NOGZIP => "³B²z .tar.gz Àɮ׮ɡB»Ý­n Compress::Zlib ¼Ò²Õ¡C", + SKIPPING_FILE => "²¤¹L %s\n", + OVERWRITTING_FILE => "»\¹L %s ¸ê®Æ", + SKIPPING_MATCHED => "¦b²Å¦Xªº¥Ø¿ý¸Ì²¤¹L %s \n", + BACKING_UP_FILE => "»s§@ %s ³Æ¥÷\n", + ERR_OPENTAR => ' +µLªk¶}±Ò install.dat¡I¦w¸Ëµ{¦¡»Ý­nŪ¨ú¦¹ÀÉ¡C½Ð½T»{¦¹Àɮצs¦b¡BÀÉ®×Åv­­³]©w¥¿½T¡C + +¿ù»~°T®§¡G + %s + +¦pªG±z»Ý­n¥ô¦ó¨ó§U¡A½Ð¨ì¡G + http://gossamer-threads.com/scripts/support/ +', + ERR_OPENTAR_UNKNOWN => ' +¶}±Ò tar Àɮɵo¥Í¤F¤£©úªº¿ù»~¡G + %s + +¦pªG±z»Ý­n¥ô¦ó¨ó§U¡A½Ð¨ì¡G +http://gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\n§Ú­Ì¤w»`¶°¤F©Ò¦³¥²¶·ªº¸ê®Æ\n\n", + ENTER_STARTS => "\n«ö ENTER ¨Ó¶i¦æ¦w¸Ë¡B©Î«ö CTRL-C ¨ú®ø", + NOW_UNARCHIVING => ' + +¦w¸Ëµ{¦¡±N·Ç³Æ¬° %s ¶i¦æ¸ÑÀ£ÁY°Ê§@¡C½Ð­@¤ßµ¥­Ô... +', + UPGRADE_DONE => ' + +®¥³ß±z¡I±zªº %s ª©¥»¤w¦¨¥\ªº¤É¯Å¦Ü %s ª©¡C¦w¸ËÀɮפw³Q²¾°£¡C + +¦pªG±z»Ý­n­«·s°õ¦æ¦w¸Ë¡A½Ð¥Ñ±z³Ìªì¤U¸üªºÀ£ÁYÀɤ¤±N¦w¸ËÀɮ׸ÑÀ£ÁY¡C +', + INSTALL_DONE => ' + +%s ¤w§¹¦¨¸ÑÀ£ÁY°Ê§@¡C¦w¸ËÀɮפw³Q²¾°£¡C +¦pªG±z»Ý­n­«·s°õ¦æ¦w¸Ë¡A½Ð¥Ñ±z³Ìªì¤U¸üªºÀ£ÁYÀɤ¤¸ÑÀ£ÁY¡C + +³Æµù¡G½ÐÁקK±N±z³Ìªìªº .tar.gz Àɮׯd¦b±zªººô¸ô¥Ø¿ý¤¤¡I + +', + TELNET_ERR => '¿ù»~¡G %s', + FIRST_SCREEN => ' + + + Åwªï¨Ï¥Î <%product%> <%version%> + + +
        + + + + + +
        +

         <%product%> + ¦w¸Ë +

        +
        +
        +


        + Åwªï¨Ï¥Î <%product%>¡C¥»¦w¸Ëµ{¦¡±N·|°õ¦æ <%product%> ªº¸ÑÀ£ÁY°Ê§@¡B + ³]©w©Ò¦³ÀÉ®×Åv­­¡B¤Î¥¿½Tªº³]©w¨ì Perl ªº¸ô®|¡C + + <%error%> + +
          + + + <%message%> + + + + + + + + + + + + + + + + +
        + ½Ð°Ý±z­n§@¥þ·s¦w¸Ë©Î¬O±N²{¦³ª©¥»¤É¯Å¡H +
        ¥þ·s¦w¸Ë
        ª©¥»¤É¯Å
        ¦Ü²{¦³ª©¥»ªº admin ¸ô®|¡]ª©¥»¤É¯Å¡^¡G
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_FIRST_SCREEN => ' + + + Åwªï¨Ï¥Î <%product%> <%version%> + + +
        + + + + + + + +
        +

         <%product%> + ¦w¸Ë +

        +
        +
        +


        + Åwªï¨Ï¥Î <%product%>¡C¥»¦w¸Ëµ{¦¡±N·|°õ¦æ <%product%> ªº¸ÑÀ£ÁY°Ê§@¡B + ³]©w©Ò¦³ÀÉ®×Åv­­¡B¤Î¥¿½Tªº³]©w¨ì Perl ªº¸ô®|¡C¦b¶i¦æ¤U¤@¨B¤§«e¡A±z¥²¶·ª¾¹D¥H¤Uªº¸ê®Æ¡C¤j³¡¤ÀªºÄæ¦ì³£¤w¿é¤J¦X²zªº¹w³]­È¡A + ¦ý½ÐÀˬd¥¦­Ì¬O§_¥¿½T¡C + + <%error%> +
          + + + <%upgrade_form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_SECOND_SCREEN_FIRST => ' + + + Åwªï¨Ï¥Î <%product%> + + + + + + + + +
        +

         <%product%> + ¦w¸Ë +

        +
        +
        +


        + + ²{¦b¥¿±Nµ{¦¡¸ÑÀ£ÁY¡A½Ð±z­@¤ßµ¥­Ô¡A¤£­n«ö°±¤îÁä¡C +

        +
        +
        +
        +
        +',
        +    UPGRADE_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> ¤w§¹¦¨¸ÑÀ£ÁY°Ê§@¡C + +<%install_message%> + +

        ½ÐÁקK±N±z³Ìªìªº .tar.gz Àɮׯd¦b±zªººô¸ô¥Ø¿ý¤¤¡I + +

        ¦pªG±z¦³¥ô¦ó°ÝÃD¡A±z¥i¥H¨ì§Ú­Ìªº¤ä´©°Q½×°Ï´M¨D¤ä´©¡C +<%message%> +
          +

        + +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_WARNING => '

        ĵ§i¡G ½Ð±N install.cgi ©M install.dat ±q¥»¥Ø¿ý¤¤²¾°£¡C±N³o¨ÇÀɮׯd¦b³o¸Ì±N¤Þ°_¦w¥þ¤WªººÃ¼{¡C', + INSTALL_REMOVED => '

        ¦w¸ËÀɮפw³Q²¾°£¡C¦pªG±z»Ý­n­«·s°õ¦æ¦w¸Ë¡A½Ð¥Ñ±z³Ìªì¤U¸üªºÀ£ÁYÀɤ¤¸ÑÀ£ÁY¡C', + + OVERWRITE => '»\¹L\n', + BACKUP => '³Æ¥÷', + SKIP => '²¤¹L', + INSTALL_FIRST_SCREEN => ' + + + Åwªï¨Ï¥Î <%product%> <%version%> + + +

        + + + + + + +
        +

         <%product%> + ¦w¸Ë +

        +
        +
        +


        + Åwªï¨Ï¥Î <%product%>¡C¥»¦w¸Ëµ{¦¡±N·|°õ¦æ <%product%>ªº¸ÑÀ£ÁY°Ê§@¡B³]©w©Ò¦³ÀÉ®×Åv­­¡B + ¤Î¥¿½Tªº³]©w¨ì Perl ªº¸ô®|¡C ¦b¶i¦æ¤U¤@¨B¤§«e¡A±z¥²¶·ª¾¹D¥H¤Uªº¸ê®Æ¡C¤j³¡¤ÀªºÄæ¦ì³£¤w¿é¤J¦X²zªº¹w³]­È¡A¦ý½ÐÀˬd¥¦­Ì¬O§_¥¿½T¡C + + <%error%> +
        + + + <%form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_SECOND_SCREEN_FIRST => ' + + + Åwªï¨Ï¥Î <%product%> + + + + + + + + +
        +

         <%product%> + ¦w¸Ë +

        +
        +
        +


        + + ²{¦b¥¿±Nµ{¦¡¸ÑÀ£ÁY¡C½Ð±z­@¤ßµ¥­Ô¡A¤£­n«ö°±¤îÁä¡C +

        +
        +
        +
        +
        +',
        +    INSTALL_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> ¤w§¹¦¨¸ÑÀ£ÁY°Ê§@¡C + +<%install_message%> + +

        ½ÐÁקK±N±z³Ìªìªº .tar.gz Àɮׯd¦b±zªººô¸ô¥Ø¿ý¤¤¡I + +

        ¦pªG±z¦³¥ô¦ó°ÝÃD¡A±z¥i¥H¨ì§Ú­Ìªº¤ä´©°Q½×°Ï´M¨D¤ä´©¡C +<%message%> +
          +

        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + CGI_ERROR_SCREEN => ' + + + Error + + + + + + +
        +

         ¿ù»~ +

        +
        +
        +


        + µo¥Í¿ù»~¡G + + <%error%> +
        +

        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INVALID_RESPONCE => "\nµL®Äªº¦^À³ (%s)\n", +); + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.de b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.de new file mode 100644 index 0000000..69c5aea --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.de @@ -0,0 +1,1434 @@ +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s darf nicht leer sein.", + ERR_PATH => "Das Verzeichnis (%s) existiert auf diesem System nicht.", + ERR_PATHWRITE => "In das Verzeichnis '%s' kann nicht geschrieben werden. Grund: %s", + ERR_PATHCREATE => "Das Verzeichnis '%s' kann nicht angelegt werden. Grund: %s", + ERR_URLFMT => "'%s' ist kein gültiges URL Format.", + ERR_FTPFMT => "'%s' ist kein gültiges FTP-URL Format.", + ERR_EMAILFMT => "'%s' ist kein gültiges Email Format.", + ERR_SENDMAIL => "Das Verzeichnis (%s) existiert auf diesem System nicht oder ist nicht ausführbar", + ERR_SMTP => "'%s' ist keine gültige SMTP-Server Adresse", + ERR_PERL => "Das angegebene Perl-Verzeichnis (%s) ist ungültig %s", + ERR_DIREXISTS => "Das Verzeichnis '%s' kann nicht angelegt werden. Ein Verzeichnis mit identischem Namen existiert bereits.", + ERR_WRITEOPEN => "'%s' kann zum Schreiben nicht geöffnet werden. Grund: %s", + ERR_READOPEN => "'%s' kann zum Lesen nicht geöffnet werden. Grund: %s", + ERR_RENAME => "'%s' kann nicht in '%s' umbenannt werden. Grund: %s", + ENTER_REG => 'Geben Sie bitte Ihre Registrierungsnummer an', + REG_NUM => 'Registrierungsnummer', + ENTER_SENDMAIL => 'Geben Sie bitte den Pfad von Sendmail oder Ihres SMTP Server an, um Emails zu versenden', + MAILER => 'Mailer', + ENTER_PERL => 'Geben Sie bitte das Perl Verzeichnis an', + PATH_PERL => 'Perl-Verzeichnis', + CREATE_DIRS => 'Verzeichnisse anlegen', + INSTALL_CURRUPTED => ' +Die Datei Install.dat scheint unvollständig zu sein. Bitte prüfen Sie, ob der FTP-Upload im BINARY Modus durchgeführt worden ist. +Wenn Sie einen ASCII Transfer vorgenommen haben, ist Ihre Installationsdatei beschädigt. Bitte führen Sie einen neuen Upload auf Ihren Server durch. + +Wenn Sie Hilfe benötigen, besuchen Sie bitte : + http://malinet.de oder http://gossamer-threads.com/scripts/support/ +', + INSTALL_VERSION => ' +Diese Software setzt eine Perl Version 5.004_04 oder grösser voraus. Auf Ihrem System wurde +Version %s gefunden. Bitte ändern Sie den Perl-Pfad bei Aufruf des install.cgi Skriptes +auf eine neuere Version oder wenden Sie sich für weitere Hilfe an Ihren Provider. +', + ADMIN_PATH_ERROR => "Sie müssen den Pfad der Administration Ihrer bereits installierten Version angeben", + INTRO => ' +%s Schnell-Installation http://gossamer-threads.com +Copyright (c) 2008 Gossamer Threads Inc. All Rights Reserved +Redistribution in part or in whole strictly prohibited. + +deutsche Version +Copyright (c) 2008 malinet Informatik alle Rechte vorbehalten +Ein Weiterverkauf von Teilen oder als Ganzes ist strengstens untersagt. +', + WELCOME => ' +Willkommen zu %s. Dieses Programm wird das Archiv von %s auspacken, alle notwendigen Dateien anlegen und entsprechende Rechte setzen. + +Um mit der Installation zu beginnen, geben Sie die folgenden Informationen an. Sie können jederzeit den Vorgang mit "exit" oder "quit" abbrechen. +', + IS_UPGRADE => "Soll ein Upgrade einer vorhandenen Installation durchgeführt werden", + ENTER_ADMIN_PATH => "\nBitte geben Sie das Verzeichnis der Administration an", + UNARCHIVING => 'Dekomprimierung', + TAR_OPEN => "'%s' kann nicht geöffnet werden. Grund: %s", + TAR_READ => "Beim Lesen der Datei %s ist ein Fehler aufgetreten. Es wurden %s Bytes erwartet, aber nur %s Bytes sind angekommen.", + TAR_BINMODE => "'%s' kann kein Binärmodus sein. Grund: %s", + TAR_BADARGS => "Es wurden an %s ungültige Parameter übergeben. Grund: %s", + TAR_CHECKSUM => "Checksummen Fehler im TAR-Archiv aufgetreten. In den meisten Fällen ist das TAR-Archiv fehlerhaft.\nHeader: %s\nChecksumme: %s\nDatei: %s\n", + TAR_NOBODY => "Die Datei '%s' hat keine Daten!", + TAR_CANTFIND => "Die Datei '%s' kann nicht im TAR-Archiv gefunden werden.", + TAR_CHMOD => "Der Befehl chmod %s kann nicht durchgeführt werden. Grund: %s", + TAR_DIRFILE => "Ein Verzeichnis mit dem gleichen Namen '%s' kann nicht erstellt werden!", + TAR_MKDIR => "Der Befehl mkdir %s kann nicht durchgeführt werden. Grund: %s", + TAR_RENAME => "Die temporäre Datei '%s' kann im TAR-Archiv nicht in '%s' umbenannt werden. Grund: %s", + TAR_NOGZIP => "Compress::Zlib Modul ist für die Verwendung von .tar.gz Dateien notwendig.", + SKIPPING_FILE => "Datei %s wird übersprungen\n", + OVERWRITTING_FILE => "Datei %s wird überschrieben", + SKIPPING_MATCHED => "Überspringen von %s im Verzeichnis\n", + BACKING_UP_FILE => "Backup von %s\n", + ERR_OPENTAR => ' +Die Datei install.dat kann nicht geöffnet werden! Bitte prüfen Sie das Vorhandensein im richtigen Verzeichnis und die Dateirechte, um die Datei lesen zu können. + +Folgender Fehler trat auf: + %s + +Wenn Sie Hilfe brauchen, besuchen Sie bitte die Seite: + http://malinet.de oder http://gossamer-threads.com/scripts/support/ + ', + ERR_OPENTAR_UNKNOWN => ' +Unbekannter Fehler beim Lesen des TAR-Archivs aufgetreten: + %s + +Wenn Sie Hilfe brauchen, besuchen Sie bitte die Seite: + http://malinet.de oder http://gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\nSie haben alle notwendigen Informationen angegeben. Die Installation der Dateien kann beginnen...\n\n", + ENTER_STARTS => "\nDrücken Sie bitte RETURN, um zu installieren oder STRG-C um abzubrechen.", + NOW_UNARCHIVING => ' + +Die Datei %s wird jetzt dekomprimiert. Alle Dateien werden in das richtige Verzeichnis geschrieben. Bitte haben Sie Geduld... +', + UPGRADE_DONE => ' + +Gratulation! Ihre Installation von %s wurde auf Version %s upgedatet. Die Installationsdateien wurden gelöscht. + +Wenn Sie die Installation erneut durchführen wollen, dekomprimieren Sie bitte erneut die Original-Datei. +', + INSTALL_DONE => ' + +%s ist nun installiert. Die Installationsdateien wurden gelöscht. +Wenn Sie die Installation erneut durchführen wollen, dekomprimieren Sie bitte erneut die Original-Datei. + +HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem +Web-Verzeichnis! + +', + TELNET_ERR => 'Fehler: %s', + INSTALLER_CSS => <<'CSS', #> - help vim in ft=html mode + +CSS + TELNET_EULA => <<'EULA', +GOSSAMER THREADS INC. +LIZENZVEREINBARUNG FÜR ENDBENUTZER + +WICHTIG: LESEN SIE DIESE LIZENZVEREINBARUNG, BEVOR SIE DIE SOFTWARE INSTALLIEREN +ZUM BESSEREN VERSTÄNDNIS LIEFERN WIR IHNEN NACHFOLGEND EINE DEUTSCHE ÜBERSETZUNG: + +Dieses Software-Produkt (die "Software") und die mitgelieferte Dokumentation +(die "Dokumentation") (zusammen, das "Produkt") werden nur unter Lizenz von +Gossamer Threads Inc. (nachfolgend "GTI" genannt) dem Kunden für seinen +Gebrauch auf Grundlage dieser Vereinbarung zur Verfügung gestellt. Sie sollten +die folgende Lizenzvereinbarung sorgfältig lesen, bevor Sie das Produkt +downloaden und installieren oder die Dokumentation verwenden. Die Installation +oder die Verwendung irgendeines Teils der Software zeigt an, daß Sie diese +Bedingungen annehmen. Wenn Sie mit der nachfolgenden Lizenzvereinbarung nicht +einverstanden sind, dürfen Sie die Software nicht downloaden, installieren oder +benutzen und nicht "Ich habe die Lizenzvereinbarung gelesen und akzeptiert" +auswählen. Wenn Sie das Produkt auf einem Datenträger erhalten haben, geben +Sie bitte das vollständige Produkt inklusive Dokumentation und Verpackung +unbenutzt an Ihren Lieferanten zurück. + +1. Lizenz: GTI bewilligt Ihnen ein persönliches, nicht exklusives, nicht + übertragbares Recht, die Software in der ausführbaren Weise und die + Dokumentation zu nutzen, wie es in dieser Vereinbarung festgelegt ist. + Der Lizenznehmer darf das Produkt nicht vermieten, verleihen, + verteilen, veröffentlichen oder anderweitig in irgendeiner Art und + Weise gewerblich verwenden. Wenn Sie das Produkt mit Ihren Rechten an + eine andere Person weitergeben möchten, müssen Sie alle Kopien auf + Ihren Computern löschen und die Verwendung beenden. GTI bewilligt Ihnen + keine Lizenz am Quellcode der Software. Diese Lizenzvereinbarung + bewilligt Ihnen weiterhin keine Rechte an Patenten, Copyrights, + Geschäftsgeheimnissen, eingetragenen Warenzeichen und an allen + möglichen anderen in Bezug zum Produkt stehenden Rechte. + +2. erlaubte Benutzung: Solange diese Lizenz gültig ist, sind Sie + autorisiert, eine Installation der Software für eine Domain zu nutzen. + Sie dürfen die Software auf dem Server löschen und auf einen anderen + Server installieren, wenn Sie gewährleisten, dass das Produkt nur auf + einem Server unter einer Domain zur gleichen Zeit genutzt wird. + +3. Backup und Urheberrechtsvermerke: Zur Sicherheit und Archivierung + dürfen Sie eine Kopie der Software und der Dokumentation reproduzieren. + Jede dieser Kopien muss die Rechtshinweise und Urheberrechtsvermerke + von GTI und die seiner Lizenzgeber in gleicher Form des Originals + enthalten. Sie sind einverstanden, kein Löschen oder Verändern + irgendeines Teiles der Texte und Copyrighthinweise an lizensierter + Software oder der Dokumentation, die unter dieser Vereinbarung + bereitgestellt werden, vorzunehmen. + +4. Änderungen: Sie können unbegrenzt Änderungen an der Software für Ihren + eigenen internen Gebrauch durchführen. Mit der Änderung kann der + Anspruch auf unterstützenden Support seitens GTI zurückgewiesen werden. + +5. BESCHRÄNKUNGEN DER HAFTUNG: IN KEINEM FALL IST GTI ODER DEREN PARTNER + GEGENÜBER IHNEN ODER JEDER MÖGLICHEN ANDEREN PARTEI FÜR DIE DIREKTEN, + INDIREKTEN, SPEZIELLEN, BEILÄUFIGEN ODER SONSTIGEN SCHÄDEN UND + FOLGESCHÄDEN HAFTBAR, DIE AUS DEM GEBRAUCH DER SOFTWARE, DER UNTERLAGEN + ODER IRGENDWELCHEN ABLEITUNGEN DAVON ENTSTEHEN, SELBST WENN GTI ODER + DEREN PARTNER VON DER MÖGLICHKEIT SOLCHER BESCHÄDIGUNG BENACHRICHTIGT + WORDEN IST. GTI UND PARTNER GEBEN KEINE GARANTIE AUF IRGENDWELCHE + IMPLIZIERTEN GARANTIEN DER MARKTGÄNGIGKEIT, AUF EIGNUNG ZU EINEM + BESTIMMTEN ZWECK UND AUF RECHTSVERLETZUNG. + +6. Besitz: Sie bestätigen und stimmen darin überein, dass die Struktur, + die Reihenfolge und die Organisation der Software wertvolle + Geschäftsgeheimnisse von GTI sind und dass Sie solche + Geschäftsgeheimnisse vertraulich behandeln. Weiterhin bestätigen Sie + und stimmen darin überein, dass Besitz und Titel des Produktes und + aller angefertigten Kopien, unabhängig ihrer Form oder Mediums, von GTI + gehalten werden. + +7. Entschädigung: Sie werden GTI und seine Partner von irgendwelchen und + allen Handlungen, Beschädigungen, Verbindlichkeiten, Kosten, + Ansprüchen, verbundenen Unkosten ("Ansprüche Dritter") und durch GTI + und seiner Partner verursachten Schäden in jeder Hinsicht freistellen, + die aus Ihrem Gebrauch des Produktes entstehen. Dies gilt auch für + Ansprüche durch Sie oder durch irgendwelche dritten Parteien, die auf + Ihren Gebrauch der Software zurückzuführen sind. + +8. Kündigung: Die erworbenen Lizenzen sind unbefristet, es sei denn, dass + eine Beendigung der Lizenzvereinbarung, wie unten spezifiziert, in + Kraft tritt. Sie können die Lizenz und diese Vereinbarung jederzeit + beenden, indem Sie die Software und die Dokumentation zusammen mit + allen Kopien und verwendeten Teilen in jeder möglichen Form zerstören. + Die Lizenzen und diese Vereinbarung werden auch sofort und automatisch + ohne Nachricht beendet, wenn Sie mit irgendeiner Bedingung oder Auflage + dieser Vereinbarung nicht einverstanden sind. Nach einer solchen + Beendigung sind Sie damit einverstanden, die Software und die + Dokumentation zusammen mit allen Kopien und verwendeten Teilen in jeder + möglichen Form zu zerstören. GTI und deren Partner sind zu keiner + Rückerstattung Ihnen gegenüber bei Beendigung dieser Vereinbarung aus + irgendeinem Grund verpflichtet. + +9. Für den Gebrauch durch die Regierung: Wenn Sie die Software im Namen + der Regierung der VEREINIGTEN STAATEN erworben haben, hat die Regierung + nur "eingeschränkte Rechte" an der Software und an der Dokumentation, + wie in Klausel 52.227 19(c)(2) der "U.S. Federal Acquisition + Regulations" definiert ist. + +10. Salvatorische Klausel / Schlussbestimmungen: Sollte eine gegenwärtige + oder zukünftige Bestimmung dieses Vertrages ganz oder teilweise + unwirksam/nichtig oder nicht durchführbar sein oder werden, so wird + hiervon die Gültigkeit der übrigen Bestimmungen dieses Vertrages nicht + berührt und die ungültige Klausel wird durch eine gültige, + gesetzeskonforme und durchsetzbare Klausel, die dem Sinn der ungültigen + Klausel entspricht, ersetzt. + +11. Gesamtvereinbarung: Diese Vereinbarung setzt das vollständige + Verständnis Ihrerseits voraus und Sie erkennen diese Vereinbarung + zwischen Ihnen und GTI an. Weiterhin werden alle vorherigen + Vereinbarungen in Bezug auf das Produkt ersetzt. GTI kann Teile dieser + Vereinbarung durch elektronische Nachricht an Sie ändern. + +12. Anwendbares Recht: Diese Vereinbarung wird durch die Gesetze der + Provinz von Britisch-Kolumbien und die Bundesgesetze von Kanada + geregelt unter Ausschluss der Kollisionsnormen und des Übereinkommens + der Vereinten Nationen über Verträge über den internationalen + Warenverkauf. +------------------------------------------------------------------------------- +ENGLISCHE ORIGINALFASSUNG GOSSAMER THREADS INC. +END USER PRODUCT LICENSE AGREEMENT + +IMPORTANT: READ THIS LICENSE BEFORE INSTALLING THE SOFTWARE + +This software product (the "Software") and the accompanying +documentation (the "Documentation") (together, the "Product") are +provided only under license from Gossamer Threads Inc. ("GTI") to its +customers for their use only as set forth in this Agreement. You should +carefully read the following terms and conditions before downloading, +installing and using the Software or using the Documentation. Installing +or otherwise using any part of the Software indicates that you accept +these terms and conditions. If you do not agree with the terms and +conditions of this Agreement, do not download, install or otherwise use +the Software and do not click on the "I agree" or similar button. If you +have received the Product on physical media, return the entire product +with the software and documentation unused to the supplier where you +obtained it. + +1. License: GTI grants you a personal, non exclusive, license to use the + Software in executable form and the Documentation, subject to the terms + and restrictions set forth in this Agreement. You are not permitted to + lease, rent, distribute, publish or sub license the Software or the + Documentation or to use any part of the Product in a time sharing + arrangement or in any other unauthorized manner provided that you may + transfer all your rights in the Product to another person as long as + you remove all copies from your computers and cease all use of it. GTI + does not grant you any license in the source code of the Software. + This Agreement does not grant you any rights to patents, copyrights, + trade secrets, trademarks or any other rights with respect to the + Product. + +2. Permitted Use. You are authorized to have, at any time while this + license is valid, one installation of the Software for one domain + only, and you may remove the Software from one server and install it + on another as long as it is running on only one server for one domain + only at any time. + +3. Backup and Copyright Notices. You may reproduce one copy of the + Software and the Documentation for backup or archive purposes. Any + such copies must contain GTI's and its licensors' proprietary rights + and copyright notices in the same form as on the original. You agree + not to remove or deface any portion of any legend provided on any + licensed program or documentation delivered to you under this + Agreement. + +4. Modification. You may make unlimited modifications to the Software + for your own internal use only, but any support obligations of GTI + with respect to the Software will be terminated if you do so. + +5. LIABILITY LIMITATIONS. IN NO EVENT WILL GTI BE LIABLE TO YOU OR TO + ANY OTHER PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THE SOFTWARE, THE + DOCUMENTATION OR ANY DERIVATIVES THEREOF, EVEN IF GTI HAS BEEN ADVISED + OF THE POSSIBILITY OF SUCH DAMAGE. GTI SPECIFICALLY DISCLAIMS ANY + WARRANTIES, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NON-INFRINGEMENT. THE SOFTWARE AND THE DOCUMENTATION ARE PROVIDED ON + AN "AS IS" BASIS, AND GTI HAS NO OBLIGATION TO PROVIDE MAINTENANCE, + SUPPORT, UPDATES, ENHANCEMENTS OR MODIFICATIONS EXCEPT AS SPECIFICALLY + AGREED UPON. + +6. Ownership. You acknowledge and agree that the structure, sequence and + organization of the Software are valuable trade secrets of GTI and + that you will hold such trade secrets in confidence. You further + acknowledge and agree that ownership of and title to the Product and + all subsequent copies thereof, regardless of the form or media, are + held by GTI. + +7. Indemnity. You will indemnify and save GTI harmless from any and all + actions, damages, liabilities, charges, claims and associated expenses + ("Claims") against or incurred by GTI in any way connected with your + use of the Product, whether such Claims are by you or by any third + parties as a result of or related to your use of the Software. + +8. Termination. The licenses granted hereunder are perpetual unless + terminated earlier as specified below. You may terminate the licenses + and this Agreement at any time by destroying the Software and the + Documentation together with all copies and merged portions in any + form. The licenses and this Agreement will also terminate immediately + and automatically without notice if you fail to comply with any term + or condition of this Agreement. Upon such termination you agree to + destroy the Software and the Documentation, together with all copies + and merged portions in any form. GTI will not be liable for any + refund to you on termination of this Agreement for any reason. + +9. Government Use. If you are acquiring the Software on behalf of the + U.S. government, the Government shall have only "Restricted Rights" in + the Software and the Documentation as defined in clause 52.227 + 19(c)(2) of the U.S. Federal Acquisition Regulations. + +10. Severability. If any provision of this Agreement is found to be + invalid, illegal or unenforceable, the validity, legality and + enforceability of any of the remaining provisions shall not in any way + be affected or impaired and a valid, legal and enforceable provision + of similar intent and economic impact shall be substituted therefor. + +11. Entire Agreement: This Agreement sets forth the entire understanding + and agreement between you and GTI and supersedes all prior agreements + with respect to the Product. GTI may change the terms of this + Agreement by electronic notice to you. + +12. Governing Law. This Agreement shall be governed by the laws of the + Province of British Columbia and the federal laws of Canada applicable + therein excluding its conflicts of laws principles and excluding the + United Nations Convention on Contracts for the International Sale of + Goods. + +EULA + EULA_PROMPT => 'Akzeptieren Sie die oben stehende Lizenzvereinbarung?', + EULA_REQUIRED => 'Um mit der Installation beginnen zu können, +müssen Sie die Lizenzvereinbarung annehmen. + +', + HTML_EULA => <<'EULA', + + + + <%product%> <%version%> - Installation - Lizenzvereinbarung + <%css%> + + + +
        + + +
        +
        +
        + + <%if in.eula_displayed~%> +
        +
        <%GT::Installer::tpllang('eula_required')%>
        +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer +
        + +

        Gossamer Threads Inc.

        +

        LIZENZVEREINBARUNG FÜR ENDBENUTZER

        +

        WICHTIG: LESEN SIE DIESE LIZENZVEREINBARUNG, BEVOR SIE DIE SOFTWARE INSTALLIEREN
        + ZUM BESSEREN VERSTÄNDNIS LIEFERN WIR IHNEN NACHFOLGEND EINE DEUTSCHE ÜBERSETZUNG:

        + +

        + Dieses Software-Produkt (die "Software") und die mitgelieferte Dokumentation (die + "Dokumentation") (zusammen, das "Produkt") werden nur unter Lizenz von Gossamer + Threads Inc. (nachfolgend "GTI" genannt) dem Kunden für seinen Gebrauch auf Grundlage + dieser Vereinbarung zur Verfügung gestellt. Sie sollten die folgende + Lizenzvereinbarung sorgfältig lesen, bevor Sie das Produkt downloaden und installieren + oder die Dokumentation verwenden. Die Installation oder die Verwendung irgendeines + Teils der Software zeigt an, daß Sie diese Bedingungen annehmen. Wenn Sie mit der + nachfolgenden Lizenzvereinbarung nicht einverstanden sind, dürfen Sie die Software + nicht downloaden, installieren oder benutzen und nicht "Ich habe die + Lizenzvereinbarung gelesen und akzeptiert" auswählen. Wenn Sie das Produkt auf einem + Datenträger erhalten haben, geben Sie bitte das vollständige Produkt inklusive + Dokumentation und Verpackung unbenutzt an Ihren Lieferanten zurück. +

        + +
          +
        1. + Lizenz: GTI bewilligt Ihnen ein persönliches, nicht exklusives, nicht übertragbares + Recht, die Software in der ausführbaren Weise und die Dokumentation zu nutzen, wie + es in dieser Vereinbarung festgelegt ist. Der Lizenznehmer darf das Produkt nicht + vermieten, verleihen, verteilen, veröffentlichen oder anderweitig in irgendeiner Art + und Weise gewerblich verwenden. Wenn Sie das Produkt mit Ihren Rechten an eine + andere Person weitergeben möchten, müssen Sie alle Kopien auf Ihren Computern + löschen und die Verwendung beenden. GTI bewilligt Ihnen keine Lizenz am Quellcode + der Software. Diese Lizenzvereinbarung bewilligt Ihnen weiterhin keine Rechte an + Patenten, Copyrights, Geschäftsgeheimnissen, eingetragenen Warenzeichen und an allen + möglichen anderen in Bezug zum Produkt stehenden Rechte. +
        2. + +
        3. + erlaubte Benutzung: Solange diese Lizenz gültig ist, sind Sie autorisiert, eine + Installation der Software für eine Domain zu nutzen. Sie dürfen die Software auf + dem Server löschen und auf einen anderen Server installieren, wenn Sie + gewährleisten, dass das Produkt nur auf einem Server unter einer Domain zur gleichen + Zeit genutzt wird. +
        4. + +
        5. + Backup und Urheberrechtsvermerke: Zur Sicherheit und Archivierung dürfen Sie eine + Kopie der Software und der Dokumentation reproduzieren. Jede dieser Kopien muss die + Rechtshinweise und Urheberrechtsvermerke von GTI und die seiner Lizenzgeber in + gleicher Form des Originals enthalten. Sie sind einverstanden, kein Löschen oder + Verändern irgendeines Teiles der Texte und Copyrighthinweise an lizensierter + Software oder der Dokumentation, die unter dieser Vereinbarung bereitgestellt + werden, vorzunehmen. +
        6. + +
        7. + Änderungen: Sie können unbegrenzt Änderungen an der Software für Ihren eigenen + internen Gebrauch durchführen. Mit der Änderung kann der Anspruch auf + unterstützenden Support seitens GTI zurückgewiesen werden. +
        8. + +
        9. + BESCHRÄNKUNGEN DER HAFTUNG: IN KEINEM FALL IST GTI ODER DEREN PARTNER GEGENÜBER + IHNEN ODER JEDER MÖGLICHEN ANDEREN PARTEI FÜR DIE DIREKTEN, INDIREKTEN, SPEZIELLEN, + BEILÄUFIGEN ODER SONSTIGEN SCHÄDEN UND FOLGESCHÄDEN HAFTBAR, DIE AUS DEM GEBRAUCH + DER SOFTWARE, DER UNTERLAGEN ODER IRGENDWELCHEN ABLEITUNGEN DAVON ENTSTEHEN, SELBST + WENN GTI ODER DEREN PARTNER VON DER MÖGLICHKEIT SOLCHER BESCHÄDIGUNG BENACHRICHTIGT + WORDEN IST. GTI UND PARTNER GEBEN KEINE GARANTIE AUF IRGENDWELCHE IMPLIZIERTEN + GARANTIEN DER MARKTGÄNGIGKEIT, AUF EIGNUNG ZU EINEM BESTIMMTEN ZWECK UND AUF + RECHTSVERLETZUNG. +
        10. + +
        11. + Besitz: Sie bestätigen und stimmen darin überein, dass die Struktur, die Reihenfolge + und die Organisation der Software wertvolle Geschäftsgeheimnisse von GTI sind und + dass Sie solche Geschäftsgeheimnisse vertraulich behandeln. Weiterhin bestätigen Sie + und stimmen darin überein, dass Besitz und Titel des Produktes und aller + angefertigten Kopien, unabhängig ihrer Form oder Mediums, von GTI gehalten werden. +
        12. + +
        13. + Entschädigung: Sie werden GTI und seine Partner von irgendwelchen und allen + Handlungen, Beschädigungen, Verbindlichkeiten, Kosten, Ansprüchen, verbundenen + Unkosten ("Ansprüche Dritter") und durch GTI und seiner Partner verursachten Schäden + in jeder Hinsicht freistellen, die aus Ihrem Gebrauch des Produktes entstehen. Dies + gilt auch für Ansprüche durch Sie oder durch irgendwelche dritten Parteien, die auf + Ihren Gebrauch der Software zurückzuführen sind. +
        14. + +
        15. + Kündigung: Die erworbenen Lizenzen sind unbefristet, es sei denn, dass eine + Beendigung der Lizenzvereinbarung, wie unten spezifiziert, in Kraft tritt. Sie + können die Lizenz und diese Vereinbarung jederzeit beenden, indem Sie die Software + und die Dokumentation zusammen mit allen Kopien und verwendeten Teilen in jeder + möglichen Form zerstören. Die Lizenzen und diese Vereinbarung werden auch sofort und + automatisch ohne Nachricht beendet, wenn Sie mit irgendeiner Bedingung oder Auflage + dieser Vereinbarung nicht einverstanden sind. Nach einer solchen Beendigung sind Sie + damit einverstanden, die Software und die Dokumentation zusammen mit allen Kopien + und verwendeten Teilen in jeder möglichen Form zu zerstören. GTI und deren Partner + sind zu keiner Rückerstattung Ihnen gegenüber bei Beendigung dieser Vereinbarung aus + irgendeinem Grund verpflichtet. +
        16. + +
        17. + Für den Gebrauch durch die Regierung: Wenn Sie die Software im Namen der Regierung + der VEREINIGTEN STAATEN erworben haben, hat die Regierung nur "eingeschränkte + Rechte" an der Software und an der Dokumentation, wie in Klausel 52.227 19(c)(2) der + "U.S. Federal Acquisition Regulations" definiert ist. +
        18. + +
        19. + Salvatorische Klausel / Schlussbestimmungen: Sollte eine gegenwärtige oder + zukünftige Bestimmung dieses Vertrages ganz oder teilweise unwirksam/nichtig oder + nicht durchführbar sein oder werden, so wird hiervon die Gültigkeit der übrigen + Bestimmungen dieses Vertrages nicht berührt und die ungültige Klausel wird durch + eine gültige, gesetzeskonforme und durchsetzbare Klausel, die dem Sinn der + ungültigen Klausel entspricht, ersetzt. +
        20. + +
        21. + Gesamtvereinbarung: Diese Vereinbarung setzt das vollständige Verständnis Ihrerseits + voraus und Sie erkennen diese Vereinbarung zwischen Ihnen und GTI an. Weiterhin + werden alle vorherigen Vereinbarungen in Bezug auf das Produkt ersetzt. GTI kann + Teile dieser Vereinbarung durch elektronische Nachricht an Sie ändern. +
        22. + +
        23. + Anwendbares Recht: Diese Vereinbarung wird durch die Gesetze der Provinz von + Britisch-Kolumbien und die Bundesgesetze von Kanada geregelt unter Ausschluss der + Kollisionsnormen und des Übereinkommens der Vereinten Nationen über Verträge über + den internationalen Warenverkauf. +
        24. +
        +
        +

        Gossamer Threads Inc. ENGLISCHE ORIGINALFASSUNG

        +

        End User Product License Agreement

        +

        IMPORTANT: READ THIS LICENSE BEFORE INSTALLING THE SOFTWARE

        + +

        + This software product (the "Software") and the accompanying + documentation (the "Documentation") (together, the "Product") are + provided only under license from Gossamer Threads Inc. ("GTI") to + its customers for their use only as set forth in this Agreement. + You should carefully read the following terms and conditions + before downloading, installing and using the Software or using + the Documentation. Installing or otherwise using any part of the + Software indicates that you accept these terms and conditions. If + you do not agree with the terms and conditions of this Agreement, + do not download, install or otherwise use the Software and do not + click on the "I agree" or similar button. If you have received + the Product on physical media, return the entire product with the + software and documentation unused to the supplier where you + obtained it. +

        + +
          +
        1. + License: GTI grants you a personal, non exclusive, license to + use the Software in executable form and the Documentation, + subject to the terms and restrictions set forth in this + Agreement. You are not permitted to lease, rent, distribute, + publish or sub license the Software or the Documentation or to + use any part of the Product in a time sharing arrangement or + in any other unauthorized manner provided that you may + transfer all your rights in the Product to another person as + long as you remove all copies from your computers and cease + all use of it. GTI does not grant you any license in the + source code of the Software. This Agreement does not grant you + any rights to patents, copyrights, trade secrets, trademarks + or any other rights with respect to the Product. +
        2. +
        3. + Permitted Use. You are authorized to have, at any time while + this license is valid, one installation of the Software for one + domain only, and you may remove the Software from one server + and install it on another as long as it is running on only one + server for one domain only at any time. +
        4. + +
        5. + Backup and Copyright Notices. You may reproduce one copy of + the Software and the Documentation for backup or archive + purposes. Any such copies must contain GTI's and its + licensors' proprietary rights and copyright notices in the same + form as on the original. You agree not to remove or deface any + portion of any legend provided on any licensed program or + documentation delivered to you under this Agreement. +
        6. + +
        7. + Modification. You may make unlimited modifications to the + Software for your own internal use only, but any support + obligations of GTI with respect to the Software will be + terminated if you do so. +
        8. + +
        9. + LIABILITY LIMITATIONS. IN NO EVENT WILL GTI BE LIABLE TO YOU + OR TO ANY OTHER PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL + OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THE + SOFTWARE, THE DOCUMENTATION OR ANY DERIVATIVES THEREOF, EVEN IF + GTI HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. GTI + SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING BUT NOT + LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS + FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. THE SOFTWARE AND + THE DOCUMENTATION ARE PROVIDED ON AN "AS IS" BASIS, AND GTI HAS + NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, + ENHANCEMENTS OR MODIFICATIONS EXCEPT AS SPECIFICALLY AGREED + UPON. +
        10. + +
        11. + Ownership. You acknowledge and agree that the structure, + sequence and organization of the Software are valuable trade + secrets of GTI and that you will hold such trade secrets in + confidence. You further acknowledge and agree that ownership of + and title to the Product and all subsequent copies thereof, + regardless of the form or media, are held by GTI. +
        12. + +
        13. + Indemnity. You will indemnify and save GTI harmless from any + and all actions, damages, liabilities, charges, claims and + associated expenses ("Claims") against or incurred by GTI in + any way connected with your use of the Product, whether such + Claims are by you or by any third parties as a result of or + related to your use of the Software. +
        14. + +
        15. + Termination. The licenses granted hereunder are perpetual + unless terminated earlier as specified below. You may terminate + the licenses and this Agreement at any time by destroying the + Software and the Documentation together with all copies and + merged portions in any form. The licenses and this Agreement + will also terminate immediately and automatically without + notice if you fail to comply with any term or condition of this + Agreement. Upon such termination you agree to destroy the + Software and the Documentation, together with all copies and + merged portions in any form. GTI will not be liable for any + refund to you on termination of this Agreement for any reason. +
        16. + +
        17. + Government Use. If you are acquiring the Software on behalf of + the U.S. government, the Government shall have only "Restricted + Rights" in the Software and the Documentation as defined in + clause 52.227 19(c)(2) of the U.S. Federal Acquisition + Regulations. +
        18. + +
        19. + Severability. If any provision of this Agreement is found to + be invalid, illegal or unenforceable, the validity, legality + and enforceability of any of the remaining provisions shall not + in any way be affected or impaired and a valid, legal and + enforceable provision of similar intent and economic impact + shall be substituted therefor. +
        20. + +
        21. + Entire Agreement: This Agreement sets forth the entire + understanding and agreement between you and GTI and supersedes + all prior agreements with respect to the Product. GTI may + change the terms of this Agreement by electronic notice to you. +
        22. + +
        23. + Governing Law. This Agreement shall be governed by the laws of + the Province of British Columbia and the federal laws of Canada + applicable therein excluding its conflicts of laws principles + and excluding the United Nations Convention on Contracts for + the International Sale of Goods. +
        24. +
        + +
        + + + <%if in.upgrade_choice and in.install_dir%> + + + <%endif%> +
        + +
        + +
        +
        + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +EULA + FIRST_SCREEN => <<'FIRST_SCREEN', + + + + <%product%> <%version%> - Installation + <%css%> + + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer +
        + +

        <%product%> Installer

        + +

        + Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> auspacken, + alle notwendigen Dateien anlegen, entsprechende Rechte setzen. +

        +

        Bitte wählen Sie eine der folgenden Optionen:

        + +
        + + + +
        + +
        + checked="checked"<%endunless%> /> +
        +
        +
        + + +
        + checked="checked"<%endif%> /> +
        +
        +
        + +
        + value="<%in.install_dir%>"<%endif%> /> +
        +
        + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +FIRST_SCREEN + UPGRADE_FIRST_SCREEN => <<'UPGRADE_FIRST_SCREEN', + + + + <%product%> <%version%> - Installation - Upgrade einer vorhandenen Installation + <%css%> + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer > + Upgrade einer vorhandenen Installation +
        + +

        Upgrade Ihrer bereits vorhandenen Installation

        + +

        + Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> auspacken, + und das Upgrade durchführen. + Die Installation in Ihrem angegebenen Pfad '<%in.install_dir%>' wird + aktualisiert auf <%product%> <%version%>. +

        + +
        + + + + + +<%loop rows%> +<%if skip%><%nextloop%><%endif%> +<%if type and type eq 'message'%> +
        <%message%>
        +<%else%> +
        + +
        + +
        +
        +<%endif%> +<%endloop%> + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +UPGRADE_FIRST_SCREEN + UPGRADE_SECOND_SCREEN_FIRST => <<'UPGRADE_SECOND_SCREEN_FIRST', + + + + <%product%> <%version%> - Installation - Upgrade der vorhandenen Installation beginnt + <%css%> + + +
        + + +
        +
        +
        + +
        +
        +
        +
        + +
        + <%product%> Installer > Upgrade der vorhandenen Installation beginnt > Upgrading... +
        + +

        Upgrading...

        + +

        + Das Upgrade von <%product%> auf Version <%version%> wird jetzt durchgeführt. Bitte haben + Sie Geduld und unterbrechen Sie nicht die Installation. +

        + +
        +
        +
        +
        +
        +
        + +
        +
        +UPGRADE_SECOND_SCREEN_FIRST
        +    UPGRADE_SECOND_SCREEN_SECOND => <<'UPGRADE_SECOND_SCREEN_SECOND',
        +
        +
        + +
        + +
        + +
        +
        +
        +
        +

        Upgrade erfolgreich durchgeführt

        + +

        + Das Upgrade von <%product%> auf Version <%version%> wurde erfolgreich durchgeführt. +

        + +

        + HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem Web-Verzeichnis! +

        + +

        + Wenn Sie Hilfe brauchen, besuchen Sie bitte unser Supportforum in deutsch oder eglisch. +

        +
        +
        +
        +
        +
        + +
        + + +UPGRADE_SECOND_SCREEN_SECOND + INSTALL_WARNING => '

        WARNUNG: Bitte löschen Sie die Dateien install.cgi und install.dat aus Ihrem Verzeichnis. Wenn Sie diese Dateien nicht löschen, setzen Sie sich einem hohen Sicherheitsrisiko aus!

        ', + INSTALL_REMOVED => '

        Die Installationsdateien wurden gelöscht. Wenn Sie die Installation erneut durchführen wollen, dekomprimieren Sie bitte erneut die Original-Datei.

        ', + OVERWRITE => 'Überschreiben', + BACKUP => 'Backup', + SKIP => 'Überspringen', + INSTALL_FIRST_SCREEN => <<'INSTALL_FIRST_SCREEN', + + + + <%product%> <%version%> - Neue Installation + <%css%> + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer > + Neue Installation +
        + +

        Neue Installation

        + +

        + Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> <%version%> + auspacken und installieren. Um mit der Installation zu beginnen, geben Sie bitte die + nachfolgenden Informationen an.
        + Hinweis: Einige Standardwerte wurden bereits eingesetzt. Bitte prüfen Sie diese + Werte sorgfältig. +

        + +
        + + + + + <%~loop fields%> + <%~if type eq 'message'%> +
        <%message%>
        + <%~else%> +
        + +
        + <%~if type eq 'create_dirs%> + checked="checked"<%endif%> /> + <%~else%> + + <%~endif%> +
        +
        + <%~endif%> + <%~endloop%> + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +INSTALL_FIRST_SCREEN + INSTALL_SECOND_SCREEN_FIRST => <<'INSTALL_SECOND_SCREEN_FIRST', + + + + <%product%> <%version%> - Neue Installation beginnt + <%css%> + + +
        + + +
        +
        +
        + +
        +
        +
        +
        + +
        + <%product%> Installer > Neue Installation beginnt > Installation... +
        + +

        Installation...

        + +

        + <%product%> <%version%> wird nun vollständig installiert. Bitte haben Sie Geduld + und unterbrechen Sie nicht die Installation. +

        + +
        +
        +
        +
        +
        +
        + +
        +
        +INSTALL_SECOND_SCREEN_FIRST
        +    INSTALL_SECOND_SCREEN_SECOND => <<'INSTALL_SECOND_SCREEN_SECOND',
        +
        +
        + +
        + +
        + +
        +
        +
        +
        +

        Installation abgeschlossen

        + +

        + <%product%> <%version%> wurde erfolgreich installiert. +

        + + <%if install_message%>

        <%install_message%>

        <%endif%> + +

        + HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem Web-Verzeichnis! +

        + + class="no-bmargin"<%endif%>> + Wenn Sie Hilfe brauchen, besuchen Sie bitte unser Supportforum in deutsch oder eglisch. +

        + + <%if message%>

        <%message%>

        <%endif%> + +
        +
        +
        +
        +
        + +
        + + +INSTALL_SECOND_SCREEN_SECOND + CGI_ERROR_SCREEN => <<'CGI_ERROR_SCREEN', +<%if error_breakout%><%error_breakout%><%endif%> +
        + +
        + +
        +
        +
        +
        +

        Fehler

        + +

        + Bei der Installation trat folgender Fehler auf: +

        + +

        + <%error%> +

        +
        +
        +
        +
        +
        + +
        + + +CGI_ERROR_SCREEN + INVALID_RESPONCE => "\nUngültige Antwort (%s)\n", +); + +# vim:ft=perl diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.en b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.en new file mode 100644 index 0000000..ccf7ad3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.en @@ -0,0 +1,1234 @@ +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s cannot be left blank.", + ERR_PATH => "The path (%s) does not exist on this system", + ERR_PATHWRITE => "Unable to write to directory '%s': %s", + ERR_PATHCREATE => "Unable to create directory '%s': %s", + ERR_URLFMT => "'%s' is not a valid URL", + ERR_FTPFMT => "'%s' is not a valid FTP URL", + ERR_EMAILFMT => "'%s' is not a valid e-mail address", + ERR_SENDMAIL => "The sendmail path (%s) does not exist on your system or is not executable", + ERR_SMTP => "'%s' is not a valid SMTP server address", + ERR_PERL => "The path to perl you specified (%s) %s", + ERR_DIREXISTS => "Directory '%s' cannot be created; a file/directory with the same name already exists", + ERR_WRITEOPEN => "Could not write to '%s': %s\n", + ERR_READOPEN => "Could not read '%s': %s\n", + ERR_RENAME => "Could not rename '%s' to '%s': %s\n", + ENTER_REG => 'Please enter your registration number', + REG_NUM => 'Registration Number', + ENTER_SENDMAIL => 'Please enter either a path to sendmail, or an SMTP server to use for sending mail', + MAILER => 'Mailer', + ENTER_PERL => 'Please enter the path to perl', + PATH_PERL => 'Path to perl', + CREATE_DIRS => 'Create Directories', + INSTALL_CURRUPTED => ' +install.dat appears to be corrupted. If you are using FTP to transer the file +be sure to upload the file in BINARY mode. + +If you need assistance, please visit: + http://www.gossamer-threads.com/scripts/support/ +', + INSTALL_VERSION => ' +This program requires Perl version 5.004_04 or greater to run. Your +system is only running version %s. Try changing the path to perl in +install.cgi to a newer version, or contact your ISP for help. +', + ADMIN_PATH_ERROR => "You must specify the path to the previous installation's admin area", + INTRO => ' +%s Quick Install http://www.gossamer-threads.com +Copyright (c) 2008 Gossamer Threads Inc. All Rights Reserved +Redistribution in part or in whole strictly prohibited. +', + WELCOME => ' +Welcome to %s. This program will unarchive and install %s. + +To begin, please enter the following information. Type exit +or quit at any time to abort. +', + IS_UPGRADE => "Is this an upgrade of an existing installation", + ENTER_ADMIN_PATH => "\nPlease enter path to current admin", + UNARCHIVING => 'Unarchiving', + TAR_OPEN => "Could not open '%s': %s", + TAR_READ => "There was an error reading from '%s': expected to read %s bytes, but only got %s.", + TAR_BINMODE => "Could not binmode '%s': %s", + TAR_BADARGS => "Bad arguments passed to %s: %s", + TAR_CHECKSUM => "Checksum Error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n", + TAR_NOBODY => "File '%s' does not have a body!", + TAR_CANTFIND => "Unable to find a file named: '%s' in tar archive.", + TAR_CHMOD => "Could not chmod %s, Reason: %s", + TAR_DIRFILE => "Directory '%s' cannot be created; a file with the same name already exists", + TAR_MKDIR => "Could not mkdir %s, Reason: %s", + TAR_RENAME => "Unable to rename temp file: '%s' to tar file '%s'. Reason: %s", + TAR_NOGZIP => "Compress::Zlib module is required to work with .tar.gz files.", + SKIPPING_FILE => "Skipping %s\n", + OVERWRITTING_FILE => "Overwriting %s\n", + SKIPPING_MATCHED => "Skipping %s in matched directory\n", + BACKING_UP_FILE => "Backing up %s\n", + ERR_OPENTAR => ' +Unable to open the install.dat file! Please make sure the +file exists and that the permissions are set properly so the +program can read the file. + +The error message was: + %s + +If you need assistance, please visit: + http://www.gossamer-threads.com/scripts/support/ + ', + ERR_OPENTAR_UNKNOWN => ' +Unknown error opening tar file: + %s + +If you need assistance, please visit: +http://www.gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\nWe have everything we need to proceed.\n\n", + ENTER_STARTS => "\nPress ENTER to install, or CTRL-C to abort", + NOW_UNARCHIVING => ' + +We are now unarchiving %s and will be extracting +all the files shortly. Please be patient... +', + UPGRADE_DONE => ' + +Congratulations! Your copy of %s has now been +updated to version %s. The install files have +been removed. + +If you need to re-run the install, please unarchive the +original file again. +', + INSTALL_DONE => ' + +%s is now unarchived. The install files have been +removed. If you need to re-run the install, please unarchive +the original file again. + +NOTE: Please do not leave your original .tar.gz file in your +web directory! + +', + TELNET_ERR => 'Error: %s', + INSTALLER_CSS => <<'CSS', #> - help vim in ft=html mode + +CSS + TELNET_EULA => <<'EULA', +GOSSAMER THREADS INC. +END USER PRODUCT LICENSE AGREEMENT + +IMPORTANT: READ THIS LICENSE BEFORE INSTALLING THE SOFTWARE + +This software product (the "Software") and the accompanying +documentation (the "Documentation") (together, the "Product") are +provided only under license from Gossamer Threads Inc. ("GTI") to its +customers for their use only as set forth in this Agreement. You should +carefully read the following terms and conditions before downloading, +installing and using the Software or using the Documentation. Installing +or otherwise using any part of the Software indicates that you accept +these terms and conditions. If you do not agree with the terms and +conditions of this Agreement, do not download, install or otherwise use +the Software and do not click on the "I agree" or similar button. If you +have received the Product on physical media, return the entire product +with the software and documentation unused to the supplier where you +obtained it. + +1. License: GTI grants you a personal, non exclusive, license to use the + Software in executable form and the Documentation, subject to the terms + and restrictions set forth in this Agreement. You are not permitted to + lease, rent, distribute, publish or sub license the Software or the + Documentation or to use any part of the Product in a time sharing + arrangement or in any other unauthorized manner provided that you may + transfer all your rights in the Product to another person as long as + you remove all copies from your computers and cease all use of it. GTI + does not grant you any license in the source code of the Software. + This Agreement does not grant you any rights to patents, copyrights, + trade secrets, trademarks or any other rights with respect to the + Product. +<%if product eq 'Gossamer Mail' and not version ends '-Single'%> +2. Permitted Use. You are authorized to have, at any time while this + license is valid, one installation of the Software only, and you may + remove the Software from one server and install it on another as long + <%~if version ends '-Enterprise' or version ends '-Upgrade'%> + as it is running on only one server at any time. + <%~elsif version ends '-Professional'%> + as it is running on only one server for a maximum of one hundred + domains only at any time. + <%~else%> + as it is running on only one server for a maximum of five domains only + at any time. + <%~endif%> +<%else%> +2. Permitted Use. You are authorized to have, at any time while this + license is valid, one installation of the Software for one domain + only, and you may remove the Software from one server and install it + on another as long as it is running on only one server for one domain + only at any time. +<%endif%> +3. Backup and Copyright Notices. You may reproduce one copy of the + Software and the Documentation for backup or archive purposes. Any + such copies must contain GTI's and its licensors' proprietary rights + and copyright notices in the same form as on the original. You agree + not to remove or deface any portion of any legend provided on any + licensed program or documentation delivered to you under this + Agreement. + +4. Modification. You may make unlimited modifications to the Software + for your own internal use only, but any support obligations of GTI + with respect to the Software will be terminated if you do so. + +5. LIABILITY LIMITATIONS. IN NO EVENT WILL GTI BE LIABLE TO YOU OR TO + ANY OTHER PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THE SOFTWARE, THE + DOCUMENTATION OR ANY DERIVATIVES THEREOF, EVEN IF GTI HAS BEEN ADVISED + OF THE POSSIBILITY OF SUCH DAMAGE. GTI SPECIFICALLY DISCLAIMS ANY + WARRANTIES, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NON-INFRINGEMENT. THE SOFTWARE AND THE DOCUMENTATION ARE PROVIDED ON + AN "AS IS" BASIS, AND GTI HAS NO OBLIGATION TO PROVIDE MAINTENANCE, + SUPPORT, UPDATES, ENHANCEMENTS OR MODIFICATIONS EXCEPT AS SPECIFICALLY + AGREED UPON. + +6. Ownership. You acknowledge and agree that the structure, sequence and + organization of the Software are valuable trade secrets of GTI and + that you will hold such trade secrets in confidence. You further + acknowledge and agree that ownership of and title to the Product and + all subsequent copies thereof, regardless of the form or media, are + held by GTI. + +7. Indemnity. You will indemnify and save GTI harmless from any and all + actions, damages, liabilities, charges, claims and associated expenses + ("Claims") against or incurred by GTI in any way connected with your + use of the Product, whether such Claims are by you or by any third + parties as a result of or related to your use of the Software. + +8. Termination. The licenses granted hereunder are perpetual unless + terminated earlier as specified below. You may terminate the licenses + and this Agreement at any time by destroying the Software and the + Documentation together with all copies and merged portions in any + form. The licenses and this Agreement will also terminate immediately + and automatically without notice if you fail to comply with any term + or condition of this Agreement. Upon such termination you agree to + destroy the Software and the Documentation, together with all copies + and merged portions in any form. GTI will not be liable for any + refund to you on termination of this Agreement for any reason. + +9. Government Use. If you are acquiring the Software on behalf of the + U.S. government, the Government shall have only "Restricted Rights" in + the Software and the Documentation as defined in clause 52.227 + 19(c)(2) of the U.S. Federal Acquisition Regulations. + +10. Severability. If any provision of this Agreement is found to be + invalid, illegal or unenforceable, the validity, legality and + enforceability of any of the remaining provisions shall not in any way + be affected or impaired and a valid, legal and enforceable provision + of similar intent and economic impact shall be substituted therefor. + +11. Entire Agreement: This Agreement sets forth the entire understanding + and agreement between you and GTI and supersedes all prior agreements + with respect to the Product. GTI may change the terms of this + Agreement by electronic notice to you. + +12. Governing Law. This Agreement shall be governed by the laws of the + Province of British Columbia and the federal laws of Canada applicable + therein excluding its conflicts of laws principles and excluding the + United Nations Convention on Contracts for the International Sale of + Goods. + +EULA + EULA_PROMPT => 'Do you accept the terms of the above license agreement?', + EULA_REQUIRED => 'You must accept the terms of the license agreement before +proceeding with the installation. + +', + HTML_EULA => <<'EULA', + + + + <%product%> <%version%> - Installation - End User Product License Agreement + <%css%> + + + +
        + + +
        +
        +
        + + <%if in.eula_displayed~%> +
        +
        <%GT::Installer::tpllang('eula_required')%>
        +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer +
        + +

        Gossamer Threads Inc.

        +

        End User Product License Agreement

        +

        IMPORTANT: READ THIS LICENSE BEFORE INSTALLING THE SOFTWARE

        + +

        + This software product (the "Software") and the accompanying + documentation (the "Documentation") (together, the "Product") are + provided only under license from Gossamer Threads Inc. ("GTI") to + its customers for their use only as set forth in this Agreement. + You should carefully read the following terms and conditions + before downloading, installing and using the Software or using + the Documentation. Installing or otherwise using any part of the + Software indicates that you accept these terms and conditions. If + you do not agree with the terms and conditions of this Agreement, + do not download, install or otherwise use the Software and do not + click on the "I agree" or similar button. If you have received + the Product on physical media, return the entire product with the + software and documentation unused to the supplier where you + obtained it. +

        + +
          +
        1. + License: GTI grants you a personal, non exclusive, license to + use the Software in executable form and the Documentation, + subject to the terms and restrictions set forth in this + Agreement. You are not permitted to lease, rent, distribute, + publish or sub license the Software or the Documentation or to + use any part of the Product in a time sharing arrangement or + in any other unauthorized manner provided that you may + transfer all your rights in the Product to another person as + long as you remove all copies from your computers and cease + all use of it. GTI does not grant you any license in the + source code of the Software. This Agreement does not grant you + any rights to patents, copyrights, trade secrets, trademarks + or any other rights with respect to the Product. +
        2. +
        3. +<%~if product eq 'Gossamer Mail' and not version ends '-Single'%> + Permitted Use. You are authorized to have, at any time while + this license is valid, one installation of the Software only, + and you may remove the Software from one server and install it + on another as long as it is running on only one server + <%~if version ends '-Enterprise' or version ends '-Upgrade'%> + at any time. + <%~elsif version ends '-Professional'%> + for a maximum of one hundred domains only at any time. + <%~else%> + for a maximum of five domains only at any time. + <%~endif%> +<%~else%> + Permitted Use. You are authorized to have, at any time while + this license is valid, one installation of the Software for one + domain only, and you may remove the Software from one server + and install it on another as long as it is running on only one + server for one domain only at any time. +<%~endif%> +
        4. + +
        5. + Backup and Copyright Notices. You may reproduce one copy of + the Software and the Documentation for backup or archive + purposes. Any such copies must contain GTI's and its + licensors' proprietary rights and copyright notices in the same + form as on the original. You agree not to remove or deface any + portion of any legend provided on any licensed program or + documentation delivered to you under this Agreement. +
        6. + +
        7. + Modification. You may make unlimited modifications to the + Software for your own internal use only, but any support + obligations of GTI with respect to the Software will be + terminated if you do so. +
        8. + +
        9. + LIABILITY LIMITATIONS. IN NO EVENT WILL GTI BE LIABLE TO YOU + OR TO ANY OTHER PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL + OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THE + SOFTWARE, THE DOCUMENTATION OR ANY DERIVATIVES THEREOF, EVEN IF + GTI HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. GTI + SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING BUT NOT + LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS + FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. THE SOFTWARE AND + THE DOCUMENTATION ARE PROVIDED ON AN "AS IS" BASIS, AND GTI HAS + NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, + ENHANCEMENTS OR MODIFICATIONS EXCEPT AS SPECIFICALLY AGREED + UPON. +
        10. + +
        11. + Ownership. You acknowledge and agree that the structure, + sequence and organization of the Software are valuable trade + secrets of GTI and that you will hold such trade secrets in + confidence. You further acknowledge and agree that ownership of + and title to the Product and all subsequent copies thereof, + regardless of the form or media, are held by GTI. +
        12. + +
        13. + Indemnity. You will indemnify and save GTI harmless from any + and all actions, damages, liabilities, charges, claims and + associated expenses ("Claims") against or incurred by GTI in + any way connected with your use of the Product, whether such + Claims are by you or by any third parties as a result of or + related to your use of the Software. +
        14. + +
        15. + Termination. The licenses granted hereunder are perpetual + unless terminated earlier as specified below. You may terminate + the licenses and this Agreement at any time by destroying the + Software and the Documentation together with all copies and + merged portions in any form. The licenses and this Agreement + will also terminate immediately and automatically without + notice if you fail to comply with any term or condition of this + Agreement. Upon such termination you agree to destroy the + Software and the Documentation, together with all copies and + merged portions in any form. GTI will not be liable for any + refund to you on termination of this Agreement for any reason. +
        16. + +
        17. + Government Use. If you are acquiring the Software on behalf of + the U.S. government, the Government shall have only "Restricted + Rights" in the Software and the Documentation as defined in + clause 52.227 19(c)(2) of the U.S. Federal Acquisition + Regulations. +
        18. + +
        19. + Severability. If any provision of this Agreement is found to + be invalid, illegal or unenforceable, the validity, legality + and enforceability of any of the remaining provisions shall not + in any way be affected or impaired and a valid, legal and + enforceable provision of similar intent and economic impact + shall be substituted therefor. +
        20. + +
        21. + Entire Agreement: This Agreement sets forth the entire + understanding and agreement between you and GTI and supersedes + all prior agreements with respect to the Product. GTI may + change the terms of this Agreement by electronic notice to you. +
        22. + +
        23. + Governing Law. This Agreement shall be governed by the laws of + the Province of British Columbia and the federal laws of Canada + applicable therein excluding its conflicts of laws principles + and excluding the United Nations Convention on Contracts for + the International Sale of Goods. +
        24. +
        + +
        + + + <%if in.upgrade_choice and in.install_dir%> + + + <%endif%> +
        + +
        + +
        +
        + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +EULA + FIRST_SCREEN => <<'FIRST_SCREEN', + + + + <%product%> <%version%> - Installation + <%css%> + + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer +
        + +

        <%product%> Installer

        + +

        + Welcome to <%product%>. This program will unarchive and install <%product%>. +

        + +
        + + + +
        + +
        + checked="checked"<%endunless%> /> +
        +
        +
        + + +
        + checked="checked"<%endif%> /> +
        +
        +
        + +
        + value="<%in.install_dir%>"<%endif%> /> +
        +
        + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +FIRST_SCREEN + UPGRADE_FIRST_SCREEN => <<'UPGRADE_FIRST_SCREEN', + + + + <%product%> <%version%> - Installation - Upgrade existing installation + <%css%> + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer > + Upgrade existing installation +
        + +

        Upgrade existing installation

        + +

        + Welcome to <%product%>. This program will unarchive and install + your <%product%> upgrade. The installation located at the path + you provided, '<%in.install_dir%>', will be updated to + <%product%> <%version%>. +

        + +
        + + + + + +<%loop rows%> +<%if skip%><%nextloop%><%endif%> +<%if type and type eq 'message'%> +
        <%message%>
        +<%else%> +
        + +
        + +
        +
        +<%endif%> +<%endloop%> + +<%if fields.length%> +
        The following fields are new <%product%> fields and need to be set before continuing. Appropriate defaults have been chosen where possible.
        +<%~loop fields%> + <%~if type eq 'message'%> +
        <%message%>
        + <%~else%> +
        + +
        + <%~if type eq 'create_dirs%> + checked="checked"<%endif%> /> + <%~else%> + + <%~endif%> +
        +
        + <%~endif%> +<%~endloop%> +<%endif%> + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +UPGRADE_FIRST_SCREEN + UPGRADE_SECOND_SCREEN_FIRST => <<'UPGRADE_SECOND_SCREEN_FIRST', + + + + <%product%> <%version%> - Installation - Upgrade existing installation - Upgrading + <%css%> + + +
        + + +
        +
        +
        + +
        +
        +
        +
        + +
        + <%product%> Installer > Upgrade existing installation > Upgrading... +
        + +

        Upgrading...

        + +

        + <%product%> is now being upgraded to <%version%>. Please be + patient, and do not hit stop. +

        + +
        +
        +
        +
        +
        +
        + +
        +
        +UPGRADE_SECOND_SCREEN_FIRST
        +    UPGRADE_SECOND_SCREEN_SECOND => <<'UPGRADE_SECOND_SCREEN_SECOND',
        +
        +
        + +
        + +
        + +
        +
        +
        +
        +

        Upgrade complete

        + +

        + <%product%> has been successfully upgraded to <%version%>. +

        + +

        + Please do not leave your original .tar.gz file in your web directory! +

        + +

        + If you have any problems, please visit our support forum. +

        +
        +
        +
        +
        +
        + +
        + + +UPGRADE_SECOND_SCREEN_SECOND + INSTALL_WARNING => '

        WARNING: Please remove the install.cgi and install.dat file from this directory. It is a security risk to leave those files here.

        ', + INSTALL_REMOVED => '

        The install files have been removed. If you need to re-run the install, please unarchive the original file again.

        ', + OVERWRITE => 'Overwrite', + BACKUP => 'Backup', + SKIP => 'Skip', + INSTALL_FIRST_SCREEN => <<'INSTALL_FIRST_SCREEN', + + + + <%product%> <%version%> - Installation - New installation + <%css%> + + +
        + + +
        +
        +
        + + <%if error or message~%> +
        + <%if error%>
        <%error%>
        <%endif%> + <%if message%>
        <%message%>
        <%endif%> +
        + <%~endif%> + +
        +
        +
        +
        + +
        + <%product%> Installer > + New installation +
        + +

        New installation

        + +

        + Welcome to <%product%>. This program will unarchive and install + <%product%> <%version%>. In order to proceed, you need to + provide the following information. Sensible defaults have been + chosen where possible, but please double-check that they are + correct. +

        + +
        + + + + + <%~loop fields%> + <%~if type eq 'message'%> +
        <%message%>
        + <%~else%> +
        + +
        + <%~if type eq 'create_dirs%> + checked="checked"<%endif%> /> + <%~else%> + + <%~endif%> +
        +
        + <%~endif%> + <%~endloop%> + +
        + +
        +
        + +
        +
        +
        +
        +
        + +
        + + +INSTALL_FIRST_SCREEN + INSTALL_SECOND_SCREEN_FIRST => <<'INSTALL_SECOND_SCREEN_FIRST', + + + + <%product%> <%version%> - Installation - New installation - Installing + <%css%> + + +
        + + +
        +
        +
        + +
        +
        +
        +
        + +
        + <%product%> Installer > New installation > Installing... +
        + +

        Installing...

        + +

        + <%product%> <%version%> is now being installed. Please be + patient, and do not hit stop. +

        + +
        +
        +
        +
        +
        +
        + +
        +
        +INSTALL_SECOND_SCREEN_FIRST
        +    INSTALL_SECOND_SCREEN_SECOND => <<'INSTALL_SECOND_SCREEN_SECOND',
        +
        +
        + +
        + +
        + +
        +
        +
        +
        +

        Installation complete

        + +

        + <%product%> <%version%> has been successfully installed. +

        + + <%if install_message%>

        <%install_message%>

        <%endif%> + +

        + Please do not leave your original .tar.gz file in your web directory! +

        + + class="no-bmargin"<%endif%>> + If you have any problems, please visit our support forum. +

        + + <%if message%>

        <%message%>

        <%endif%> + +
        +
        +
        +
        +
        + +
        + + +INSTALL_SECOND_SCREEN_SECOND + CGI_ERROR_SCREEN => <<'CGI_ERROR_SCREEN', +<%if error_breakout%><%error_breakout%><%endif%> +
        + +
        + +
        +
        +
        +
        +

        Error

        + +

        + An error occurred: +

        + +

        + <%error%> +

        +
        +
        +
        +
        +
        + +
        + + +CGI_ERROR_SCREEN + INVALID_RESPONCE => "\nInvalid Response (%s)\n", +); + +# vim:ft=perl diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.fr b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.fr new file mode 100644 index 0000000..b3a6739 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.fr @@ -0,0 +1,368 @@ + +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s ne peut pas être vide.", + ERR_PATH => "Le chemin (%s) n'existe pas sur ce système.", + ERR_PATHWRITE => "Impossible d'écrire dans le répertoire (%s). Raison : (%s)", + ERR_PATHCREATE => "Impossible de créer le répertoire (%s). Raison : (%s)", + ERR_URLFMT => "(%s) ne semble pas être une URL", + ERR_FTPFMT => "(%s) ne semble pas être une URL FTP", + ERR_EMAILFMT => "(%s) ne semble pas être un email", + ERR_SENDMAIL => "Le chemin (%s) n'existe pas sur votre système ou n'est pas exécutable", + ERR_SMTP => "(%s) n'est pas une adresse de serveur smtp valide", + ERR_PERL => "Le chemin de Perl spécifié (%s) %s", + ERR_DIREXISTS => "%s n'est pas un répertoire mais existe, impossible de créer un répertoire de ce nom", + ERR_WRITEOPEN => "Impossible d'ouvrir %s pour y écrire. Raison : %s", + ERR_READOPEN => "Impossible d'ouvrir %s pour le lire. Raison : %s", + ERR_RENAME => "Impossible de renommer %s par %s; Raison : %s", + ENTER_REG => 'Merci d\'entrer votre numéro d\'enregistrement', + REG_NUM => 'Numéro d\'enregistrement', + ENTER_SENDMAIL => 'Entrez soit le chemin de sendmail, soit un serveur SMTP à utiliser pour envoyer des emails', + MAILER => 'Mailer', + ENTER_PERL => 'Entrez le chemin de Perl 5', + PATH_PERL => 'Chemin de Perl', + CREATE_DIRS => 'Création des Répertoires', + INSTALL_CURRUPTED => ' +install.dat semble corrompu. Soyez sûr d\'avoir transféré le fichier en mode BINAIRE avec votre FTP. Ou alors vous avez peut-être un fichier corrompu, dans ce cas vous devriez essayer de télécharger un nouveau fichier à partir de Gossamer Threads. + +Si vous avez besoin d\'aide visitez : + http://gossamer-threads.com/scripts/support/ +', + INSTALL_VERSION => ' +Ce programme requiert Perl version 5.004_04 ou plus pour fonctionner. Votre système utilise seulement la version %s. Essayez de changer le chemin de Perl dans install.cgi pour une version supérieure, ou contactez votre hébergeur pour de l\'aide. +', + ADMIN_PATH_ERROR => "Vous devez spécifier le chemin d'installation précédent de la zone d'Administration", + INTRO => ' +%s Installation Rapide http://gossamer-threads.com +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved +Redistribution in part or in whole strictly prohibited. + +Lisez le fichier LICENSE pour plus de détails. +', + WELCOME => ' +Bienvenue dans l\'auto-installation de %s. Ce programme va décompresser le programme %s, créer tous les fichiers nécessaires, et paramétrer toutes les permissions proprement. + +Pour commencer, entrez les informations suivantes. Vous pouvez sortir à tout moment pour abandonner. +', + IS_UPGRADE => "Est-ce une mise à jour d'une installation existante", + ENTER_ADMIN_PATH => "\nEntrez le chemin vers l'administration actuelle", + UNARCHIVING => 'Décompactage', + TAR_OPEN => "Impossible d'ouvrir %s. Raison: %s", + TAR_READ => "Il s'est produit une erreur en lisant %s. Nous aurions dû lire %s octets, mais en avons seulement eu %s.", + TAR_BINMODE => "Impossible de binmode %s. Raison: %s", + TAR_BADARGS => "Mauvais arguments transmis à %s. Raison: %s", + TAR_CHECKSUM => "Erreur de Checksum en plaçant le fichier tar. Il s'agit très probablement d'un tar corrompu.\nHeader: %s\nChecksum: %s\nFichier: %s\n", + TAR_NOBODY => "Le fichier '%s' n'a pas de corps!", + TAR_CANTFIND => "Impossible de trouver un fichier dans l'archive, nommé: '%s'.", + TAR_CHMOD => "Impossible de chmoder %s, Raison: %s", + TAR_DIRFILE => "'%s' existe et est un fichier. Impossible de créer le répertoire", + TAR_MKDIR => "Impossible de créer %s, Raison: %s", + TAR_RENAME => "Impossible de renommer le fichier temp: '%s' par le fichier tar '%s'. Raison: %s", + TAR_NOGZIP => "Compression::Module Zlib requis pour faire fonctionner des fichiers .tar.gz.", + SKIPPING_FILE => "Ignorer %s\n", + OVERWRITTING_FILE => "Remplacer %s\n", + SKIPPING_MATCHED => "Ignorer %s dans le répertoire trouvé\n", + BACKING_UP_FILE => "Sauvegarde de %s\n", + ERR_OPENTAR => ' +Impossible d\'ouvrir le fichier install.dat! Soyez certain que le fichier existe, et que les permissions sont paramétrées correctement pour que le programme lise le fichier. + +Le message d\'erreur est le suivant: + %s + +Si vous avez besoin d\'aide visitez: + http://gossamer-threads.com/scripts/support/ +', + ERR_OPENTAR_UNKNOWN => ' +Erreur inconnue en ouvrant le fichier tar: + %s + +Si vous avez besoin d\'aide visitez: +http://gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\nNous avons tout ce qui est nécessaire pour procéder.\n\n", + ENTER_STARTS => "\nAppuyez sur ENTRÉE pour installer, ou CTRL-C pour abandonner", + NOW_UNARCHIVING => ' + +Nous décompactons actuellement %s et nous décompresserons tous les fichiers rapidement. Patientez s\'il vous plaît... +', + UPGRADE_DONE => ' + +Félicitations! Votre copie de %s a été mise à jour vers la version %s. Les fichiers d\'installation ont été supprimés. + +Si vous devez relancer l\'installation, décompactez le fichier original une nouvelle fois. +', + INSTALL_DONE => ' + +%s est maintenant décompacté. Les fichiers d\'installation ont été supprimés. Si vous devez relancer l\'installation, décompactez le fichier original une nouvelle fois. + +NOTE: Ne laissez pas votre fichier original .tar.gz dans votre répertoire web! + +', + TELNET_ERR => 'Erreur: %s', + FIRST_SCREEN => ' + + + Bienvenue dans <%product%> <%version%> + + +
        + + + + + +
        +

         Installation de <%product%> + +

        +
        +
        +


        + Bienvenue dans <%product%>. Ce programme va décompacter <%product%>, et paramétrer toutes les permissions de fichier + ainsi que le chemin de Perl correctement. + + <%error%> + +
          + + + <%message%> + + + + + + + + + + + + + + + + +
        + Merci de choisir si vous souhaitez réaliser une nouvelle installation ou bien effectuer une mise à jour. +
        Nouvelle Installation
        Mettre à Jour une Installation Éxistante
        Chemin de la zone d\'administration existante:
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_FIRST_SCREEN => ' + + + Bienvenue dans <%product%> <%version%> + + +
        + + + + + + + +
        +

         Installation de <%product%> + +

        +
        +
        +


        + Bienvenue dans <%product%>. Ce programme va décompacter <%product%>, et paramétrer toutes les permissions de fichier + ainsi que le chemin de Perl correctement. Vous devez connaître les informations suivantes avant de continuer. Des paramètres par défaut ont été choisis, mais vérifiez + qu\'ils sont bien corrects. + + <%error%> +
          + + + <%upgrade_form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_SECOND_SCREEN_FIRST => ' + + + Bienvenue dans <%product%> + + + + + + + + +
        +

         Installation de <%product%> + +

        +
        +
        +


        + + Nous allons maintenant décompacter le script, veuillez patienter s\'il vous plaît, et ne pas cliquer sur Arrêter. +

        +
        +
        +
        +
        +',
        +    UPGRADE_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> est maintenant décompacté. + +<%install_message%> + +

        Merci de ne pas laisser votre fichier .tar.gz original dans votre répertoire web! + +

        Si vous avez un problème, visitez notre forum d\'assistance. +<%message%> +
          +

        + +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_WARNING => '

        ATTENTION: Supprimez les fichiers install.cgi et install.dat de ce répertoire. Il y a un risque de sécurité en les laissant ici.', + INSTALL_REMOVED => '

        Les fichiers d\'installation ont été supprimés. Si vous devez relancer l\'installation, décompactez une nouvelle fois le fichier original.', + + OVERWRITE => 'Remplacer', + BACKUP => 'Sauvegarder', + SKIP => 'Ignorer', + INSTALL_FIRST_SCREEN => ' + + + Bienvenue dans <%product%> <%version%> + + +

        + + + + + + +
        +

         Installation de <%product%> + +

        +
        +
        +


        + Bienvenue dans <%product%>. Ce programme va décompacter <%product%>, et paramétrer toutes les permissions de fichier + ainsi que le chemin de Perl correctement. Vous devez connaître les informations suivantes avant de continuer. Des paramètres par défaut ont été choisis, mais vérifiez + qu\'ils sont bien corrects. + + <%error%> +
        + + + <%form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_SECOND_SCREEN_FIRST => ' + + + Bienvenue dans <%product%> + + + + + + + + +
        +

         Installation de <%product%> + +

        +
        +
        +


        + + Nous allons maintenant décompacter le script, veuillez patienter s\'il vous plaît, et ne pas cliquer sur Arrêter. +

        +
        +
        +
        +
        +',
        +    INSTALL_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> est maintenant décompacté. + +<%install_message%> + +

        Merci de ne pas laisser votre fichier .tar.gz original dans votre répertoire web! + +

        Si vous avez des problèmes, visitez notre forum d\'assistance. +<%message%> +
          +

        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + CGI_ERROR_SCREEN => ' + + + Erreur + + + + + + +
        +

         Erreur +

        +
        +
        +


        + Une erreur s\'est produite: + + <%error%> +
        +

        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INVALID_RESPONCE => "\nRéponse Invalide (%s)\n", +); + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.it b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.it new file mode 100644 index 0000000..15d2306 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.it @@ -0,0 +1,386 @@ + +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s can not be left blank.", + ERR_PATH => "The path (%s) does not exist on this system", + ERR_PATHWRITE => "Unable to write to directory (%s). Reason: (%s)", + ERR_PATHCREATE => "Unable to create directory (%s). Reason: (%s)", + ERR_URLFMT => "(%s) does not look like a URL", + ERR_FTPFMT => "(%s) does not look like and FTP URL", + ERR_EMAILFMT => "(%s) does not look like an email", + ERR_SENDMAIL => "The path (%s) does not exist on your system or is not executable", + ERR_SMTP => "(%s) is not a valid smtp server address", + ERR_PERL => "The path to Perl you specified (%s) %s", + ERR_DIREXISTS => "%s is not a directory but exists, unable to make a directory of that name", + ERR_WRITEOPEN => "Could not open %s for writting; Reason: %s", + ERR_READOPEN => "Could not open %s for reading; Reason: %s", + ERR_RENAME => "Could not rename %s to %s; Reason: %s", + ENTER_REG => 'Please enter your registration number', + REG_NUM => 'Registration Number', + ENTER_SENDMAIL => 'Please enter either a path to sendmail, or a SMTP server to use for sending mail', + MAILER => 'Mailer', + ENTER_PERL => 'Please enter the path to Perl 5', + PATH_PERL => 'Path to Perl', + CREATE_DIRS => 'Create Directories', + INSTALL_CURRUPTED => ' +install.dat appears to be corrupted. Please make sure you transfer +the file in BINARY mode when using FTP. Otherwise you may have a +corrupted file, and you should try downloading a new file from +Gossamer Threads. + +If you need assistance, please visit: + http://gossamer-threads.com/scripts/support/ +', + INSTALL_VERSION => ' +This program requires Perl version 5.004_04 or greater to run. Your +system is only running version %s. Try changing the path to Perl in +install.cgi to a newer version, or contact your ISP for help. +', + ADMIN_PATH_ERROR => "You must specify the path to the previous install's admin area", + INTRO => ' +%s Quick Install http://gossamer-threads.com +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved +Redistribution in part or in whole strictly prohibited. + +Please see LICENSE file for full details. +', + WELCOME => ' +Welcome to the %s auto install. This program will +unarchive the %s program, and create all the +files neccessary, and set all permissions properly. + +To begin, please enter the following information. Type exit or +quit at any time to abort. +', + IS_UPGRADE => "Is this an upgrade of an existing installation", + ENTER_ADMIN_PATH => "\nPlease enter path to current admin", + UNARCHIVING => 'Unarchiving', + TAR_OPEN => "Could not open %s. Reason: %s", + TAR_READ => "There was an error reading from %s. Expected to read %s bytes, but only got %s.", + TAR_BINMODE => "Could not binmode %s. Reason: %s", + TAR_BADARGS => "Bad arguments passed to %s. Reason: %s", + TAR_CHECKSUM => "Checksum Error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n", + TAR_NOBODY => "File '%s' does not have a body!", + TAR_CANTFIND => "Unable to find a file named: '%s' in tar archive.", + TAR_CHMOD => "Could not chmod %s, Reason: %s", + TAR_DIRFILE => "'%s' exists and is a file. Cannot create directory", + TAR_MKDIR => "Could not mkdir %s, Reason: %s", + TAR_RENAME => "Unable to rename temp file: '%s' to tar file '%s'. Reason: %s", + TAR_NOGZIP => "Compress::Zlib module is required to work with .tar.gz files.", + SKIPPING_FILE => "Skipping %s\n", + OVERWRITTING_FILE => "Overwritting %s\n", + SKIPPING_MATCHED => "Skipping %s in matched directory\n", + BACKING_UP_FILE => "Backing up %s\n", + ERR_OPENTAR => ' +Unable to open the install.dat file! Please make sure the +file exists, and the permissions are set properly so the +program can read the file. + +The error message was: + %s + +If you need assistance, please visit: + http://gossamer-threads.com/scripts/support/ +', + ERR_OPENTAR_UNKNOWN => ' +Unknown error opening tar file: + %s + +If you need assistance, please visit: +http://gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\nWe have everything we need to proceed.\n\n", + ENTER_STARTS => "\nPress ENTER to install, or CTRL-C to abort", + NOW_UNARCHIVING => ' + +We are now unarchiving %s and will be extracting +all the files shortly. Please be patient ... +', + UPGRADE_DONE => ' + +Congratulations! Your copy of %s has now been +updated to version %s. The install files have +been removed. + +If you need to re-run the install, please unarchive the +original file again. +', + INSTALL_DONE => ' + +%s is now unarchived. The install files have been +removed. If you need to re-run the install, please unarchive +the original file again. + +NOTE: Please do not leave your original .tar.gz file in your +web directory! + +', + TELNET_ERR => 'Error: %s', + FIRST_SCREEN => ' + + + Welcome to <%product%> <%version%> + + +
        + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions + and path to Perl properly. + + <%error%> + +
          + + + <%message%> + + + + + + + + + + + + + + + + +
        + Please select if this is a new install or an upgrade to an exiting version. +
        New Install
        Upgrade Existing Installation
        Path to Existing Installation admin area:
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_FIRST_SCREEN => ' + + + Welcome to <%product%> <%version%> + + +
        + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions + and path to Perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check + that they are correct. + + <%error%> +
          + + + <%upgrade_form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_SECOND_SCREEN_FIRST => ' + + + Welcome to <%product%> + + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + + We are now going to unarchive the script, please be patient and do not hit stop. +

        +
        +
        +
        +
        +',
        +    UPGRADE_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> is now unarchived. + +<%install_message%> + +

        Please do not leave your original .tar.gz file in your web directory! + +

        If you have any problems, please visit our support forum. +<%message%> +
          +

        + +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_WARNING => '

        WARNING: Please remove the install.cgi and install.dat file from this directory. It is a security risk to leave those files here.', + INSTALL_REMOVED => '

        The install files have been removed. If you need to re-run the install, please unarchive the + original file again.', + + OVERWRITE => 'Overwrite', + BACKUP => 'Backup', + SKIP => 'Skip', + INSTALL_FIRST_SCREEN => ' + + + Welcome to <%product%> <%version%> + + +

        + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions + and path to Perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check + that they are correct. + + <%error%> +
        + + + <%form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_SECOND_SCREEN_FIRST => ' + + + Welcome to <%product%> + + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + + We are now going to unarchive the script, please be patient and do not hit stop. +

        +
        +
        +
        +
        +',
        +    INSTALL_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> is now unarchived. + +<%install_message%> + +

        Please do not leave your original .tar.gz file in your web directory! + +

        If you have any problems, please visit our support forum. +<%message%> +
          +

        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + CGI_ERROR_SCREEN => ' + + + Error + + + + + + +
        +

         Error +

        +
        +
        +


        + An error occurred: + + <%error%> +
        +

        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INVALID_RESPONCE => "\nInvalid Responce (%s)\n", +); + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.sp b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.sp new file mode 100644 index 0000000..da7307e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.sp @@ -0,0 +1,383 @@ + +%GT::Installer::LANG = ( + ERR_REQUIRED => "%s no se puede dejar en blanco.", + ERR_PATH => "El path (%s) no existe en el sistema", + ERR_PATHWRITE => "Incapaz de escribir en el directorio (%s). Razon: (%s)", + ERR_PATHCREATE => "Incapaz de crear directorio (%s). Razon: (%s)", + ERR_URLFMT => "(%s) parece no ser un URL", + ERR_FTPFMT => "(%s) parece no ser un URL de FTP", + ERR_EMAILFMT => "(%s) parece no ser un email", + ERR_SENDMAIL => "El path (%s) no existe en su sistema o no es ejecutable", + ERR_SMTP => "(%s) no es una direccion de servidor smptp valida", + ERR_PERL => "El path a Perl usted especifico (%s) %s", + ERR_DIREXISTS => "%s no es un directorio pero existe, no se puede hacer un directorio de ese nombre", + ERR_WRITEOPEN => "No se pudo abrir %s por escritura; Razon: %s", + ERR_READOPEN => "No se pudo abrir %s por lectura; Razon: %s", + ERR_RENAME => "No se pudo renombrar %s to %s; Razon: %s", + ENTER_REG => 'Por favor ingrese su numero de registro', + REG_NUM => 'Numero de Registro', + ENTER_SENDMAIL => 'Por favor ingrese ya sea el path a sendmail, o el servidor SMTP a usar para enviar Correo', + MAILER => 'Mailer', + ENTER_PERL => 'Por favor ingrese el path a Perl 5', + PATH_PERL => 'Path a Perl', + CREATE_DIRS => 'Crear Directorios', + INSTALL_CURRUPTED => ' +install.dat parece estar corrupto. favor de asegurarse que transfiere el archivo en modo BINARIO +cuando use FTP. de otro modo usted podra obtener el archivo corrupto, y tendra que volver a bajar un nuevo archivo desde +Gossamer Threads. + +Si necesita asistencia, favor de visitar: + http://gossamer-threads.com/scripts/support/ +', + INSTALL_VERSION => ' +Este programa requiere la version Perl 5.004_04 o mas nueva para correr. Su +Sistema esta corriendo la version %s. Trate cambiando el path a Perl en +install.cgi a la version mas actual, o contacte a su ISP para ayuda. +', + ADMIN_PATH_ERROR => "Usted tiene que especificar el path al area de administracion de la instalacion previa", + INTRO => ' +%s Quick Install http://gossamer-threads.com +Copyright (c) 2004 Gossamer Threads Inc. Todos los derechos Reservados +Redistribucion en parte o total es extrictamente prohibida. + +Por favor vea el archivo de LICENCIA para detalles mas completos. +', + WELCOME => ' +Bienvenido al %s auto install. Este programa +descompactara el %s programa, y creara todos los +archivos necesarios, y pondra todos los permisos de manera propia. + +Para empezar, por favor ingrese la siguiente informacion. presione exit o +quit en cualquier momento para abortar. +', + IS_UPGRADE => "Es esta una actualizacion de una instalacion ya existente", + ENTER_ADMIN_PATH => "\npor favor ingrese el path al actual admin", + UNARCHIVING => 'Descomprimiendo', + TAR_OPEN => "No se pudo abrir %s. Razon: %s", + TAR_READ => "Hubo un error leyendo desde %s. Se suponia leyera %s bytes, pero solo leyo %s.", + TAR_BINMODE => "No se pudo modo binario %s. Razon: %s", + TAR_BADARGS => "Malos argumentos se pasaron a %s. Razon: %s", + TAR_CHECKSUM => "analisis de chequeo de archivo tar. Es muy probable este corrupto el tar.\nHeader: %s\nChecksum: %s\nFile: %s\n", + TAR_NOBODY => "Archivo '%s' no tiene contenido!", + TAR_CANTFIND => "Incapaz de encontrar un archivo llamado: '%s' en archivo tar.", + TAR_CHMOD => "No se pudo chmod %s, Razon: %s", + TAR_DIRFILE => "'%s' existe y es un archivo. No se puede crear directorio", + TAR_MKDIR => "No se pudo mkdir %s, Razon: %s", + TAR_RENAME => "No se puede renombrar el archivo temporal: '%s' to tar file '%s'. Razon: %s", + TAR_NOGZIP => "Comprimir::El modulo Zlib es requerido para trabajar con archivos .tar.gz .", + SKIPPING_FILE => "Saltandose %s\n", + OVERWRITTING_FILE => "Sobreescribiendo %s\n", + SKIPPING_MATCHED => "Saltandose %s en directorio concordante\n", + BACKING_UP_FILE => "Respaldando %s\n", + ERR_OPENTAR => ' +No se puede abrir el archivo install.dat! por favor asegurese de que +el archivo existe, y los permisos estan puestos apropiadamente y asi el programa +podra leer el archivo. + +El mensaje de error fue: + %s + +Si necesita asistencia, favor de visitar: + http://gossamer-threads.com/scripts/support/ +', + ERR_OPENTAR_UNKNOWN => ' +error desconocido al abrir el archivo tar: + %s + +Si necesita asistencia, favor de visitar: +http://gossamer-threads.com/scripts/support/ +', + WE_HAVE_IT => "\nTenemos todo lo que necesitamos para proceder.\n\n", + ENTER_STARTS => "\nPresione ENTER para instalar, o CTRL-C para abortar", + NOW_UNARCHIVING => ' + +Ahora estamos descomprimiendo %s y terminara de extraer todos los archivos +dentro de poco. Sea paciente ... +', + UPGRADE_DONE => ' + +Felicidades! Su copia de %s ha sido ya +actualizada a la version %s. Los archivos de instalacion han sido eliminados. + +Si necesita volver a correr el instalador, favor de descomprimir el archivo +original de nuevo. +', + INSTALL_DONE => ' + +%s esta ya desomprimido. Los archivos de instalacion han sido eliminados. +Si necesita volver a correr el instalador, favor de descomprimir el archivo +original de nuevo. + +NOTA: Por favor no deje el archivo original .tar.gz file en su +directorio web! + +', + TELNET_ERR => 'Error: %s', + FIRST_SCREEN => ' + + + Bienvenido a <%product%> <%version%> + + +
        + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo y el path a Perl de manera propia. + + <%error%> + +
          + + + <%message%> + + + + + + + + + + + + + + + + +
        + Por favor seleccione si esta es una nueva instalacion o una actualizacion de una version existente. +
        Nueva Instalacion
        Actualizar Instalacion Existente
        Path a el area de admin de la Instalacion Existente:
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_FIRST_SCREEN => ' + + + Bienvenido a <%product%> <%version%> + + +
        + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo + y path a Perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido escogidos, pero por favor cheque de + nuevo que son correctos. + + <%error%> +
          + + + <%upgrade_form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + UPGRADE_SECOND_SCREEN_FIRST => ' + + + Welcome to <%product%> + + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + + Ahora descomprimiremos el script, por favor sea paciente y no cancele ni presione stop. +

        +
        +
        +
        +
        +',
        +    UPGRADE_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> esta ahora descomprimido. + +<%install_message%> + +

        Por favor no deje su archivo original .tar.gz en su directorio web! + +

        Si usted tiene algun problema, por favor visite nuestro sitio de soporter . +<%message%> +
          +

        + +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_WARNING => '

        PRECAUCION: Por favor remueva los archivos install.cgi e install.dat de este directorio. Habra un riesgo de seguridad si los deja aqui.', + INSTALL_REMOVED => '

        Los archivos de instalacion han sido eliminados. Si usted necesita volver a correr el instalador, por favor descomprima + el archivo original de nuevo.', + + OVERWRITE => 'Sobreescribir', + BACKUP => 'Respaldar', + SKIP => 'Saltar', + INSTALL_FIRST_SCREEN => ' + + + Bienvenido a <%product%> <%version%> + + +

        + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo + y path a Perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido seleccionados, pero por favor + cheque de nuevo que son correctos. + + <%error%> +
        + + + <%form%> +
        +

         
        +
          +
        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INSTALL_SECOND_SCREEN_FIRST => ' + + + Bienvenido a <%product%> + + + + + + + + +
        +

         <%product%> + Install +

        +
        +
        +


        + + Ahora descomprimiremos el script, por favor sea paciente y no cancele o presione stop. +

        +
        +
        +
        +
        +',
        +    INSTALL_SECOND_SCREEN_SECOND => '
        +
        +
        + +
        +
        +


        <%product%> esta ahora descomprimido. + +<%install_message%> + +

        Por favor no deje el archivo original .tar.gz en su directorio web! + +

        Si usted tiene algun problema, por favor visite nuestro sitio de soporte . +<%message%> +
          +

        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + CGI_ERROR_SCREEN => ' + + + Error + + + + + + +
        +

         Error +

        +
        +
        +


        + Un error ha ocurrido: + + <%error%> +
        +

        +
        +

        Copyright 2004 Gossamer +Threads Inc. 

        + + +', + INVALID_RESPONCE => "\nRespuesta Invalida (%s)\n", +); + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON.pm new file mode 100644 index 0000000..40258d3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON.pm @@ -0,0 +1,1832 @@ +package GT::JSON; + + +use strict; +use Carp (); +use base qw(Exporter); +@GT::JSON::EXPORT = qw(from_json to_json encode_json decode_json); + +BEGIN { + $GT::JSON::VERSION = '2.14'; + $GT::JSON::DEBUG = 0 unless (defined $GT::JSON::DEBUG); +} + +my $Module_XS = 'JSON::XS'; +my $Module_PP = 'GT::JSON::PP'; +my $XS_Version = '2.22'; + + +# XS and PP common methods + +my @PublicMethods = qw/ + ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed filter_json_object filter_json_single_key_object + shrink max_depth max_size encode decode decode_prefix allow_unknown +/; + +my @Properties = qw/ + ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed shrink max_depth max_size allow_unknown +/; + +my @XSOnlyMethods = qw//; # Currently nothing + +my @PPOnlyMethods = qw/ + indent_length sort_by + allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed +/; # GT::JSON::PP specific + + +# used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently) +my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die. +my $_INSTALL_ONLY = 2; # Don't call _set_methods() +my $_ALLOW_UNSUPPORTED = 0; +my $_UNIV_CONV_BLESSED = 0; + + +# Check the environment variable to decide worker module. + +unless ($GT::JSON::Backend) { + $GT::JSON::DEBUG and Carp::carp("Check used worker module..."); + + my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1; + + if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*GT::JSON::PP/) { + _load_xs($_INSTALL_DONT_DIE) or _load_pp(); + } + elsif ($backend eq '0' or $backend eq 'GT::JSON::PP') { + _load_pp(); + } + elsif ($backend eq '2' or $backend eq 'JSON::XS') { + _load_xs(); + } + else { + Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid."; + } +} + + +sub import { + my $pkg = shift; + my @what_to_export; + my $no_export; + + for my $tag (@_) { + if ($tag eq '-support_by_pp') { + if (!$_ALLOW_UNSUPPORTED++) { + JSON::Backend::XS + ->support_by_pp(@PPOnlyMethods) if ($GT::JSON::Backend eq $Module_XS); + } + next; + } + elsif ($tag eq '-no_export') { + $no_export++, next; + } + elsif ( $tag eq '-convert_blessed_universally' ) { + eval q| + require B; + *UNIVERSAL::TO_JSON = sub { + my $b_obj = B::svref_2object( $_[0] ); + return $b_obj->isa('B::HV') ? { %{ $_[0] } } + : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] + : undef + ; + } + | if ( !$_UNIV_CONV_BLESSED++ ); + next; + } + push @what_to_export, $tag; + } + + return if ($no_export); + + __PACKAGE__->export_to_level(1, $pkg, @what_to_export); +} + + +# INTERFACES + +sub to_json ($@) { + my $json = new GT::JSON; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + $json->encode($_[0]); +} + + +sub from_json ($@) { + my $json = new GT::JSON; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + return $json->decode( $_[0] ); +} + + +sub true { $GT::JSON::true } + +sub false { $GT::JSON::false } + +sub null { undef; } + + +sub require_xs_version { $XS_Version; } + +sub backend { + my $proto = shift; + $GT::JSON::Backend; +} + +#*module = *backend; + + +sub is_xs { + return $_[0]->module eq $Module_XS; +} + + +sub is_pp { + return $_[0]->module eq $Module_PP; +} + + +sub pureperl_only_methods { @PPOnlyMethods; } + + +sub property { + my ($self, $name, $value) = @_; + + if (@_ == 1) { + my %props; + for $name (@Properties) { + my $method = 'get_' . $name; + if ($name eq 'max_size') { + my $value = $self->$method(); + $props{$name} = $value == 1 ? 0 : $value; + next; + } + $props{$name} = $self->$method(); + } + return \%props; + } + elsif (@_ > 3) { + Carp::croak('property() can take only the option within 2 arguments.'); + } + elsif (@_ == 2) { + if ( my $method = $self->can('get_' . $name) ) { + if ($name eq 'max_size') { + my $value = $self->$method(); + return $value == 1 ? 0 : $value; + } + $self->$method(); + } + } + else { + $self->$name($value); + } + +} + + + +# INTERNAL + +sub _load_xs { + my $opt = shift; + + $GT::JSON::DEBUG and Carp::carp "Load $Module_XS."; + + # if called after install module, overload is disable.... why? + GT::JSON::Boolean::_overrride_overload($Module_XS); + GT::JSON::Boolean::_overrride_overload($Module_PP); + + eval qq| + use $Module_XS $XS_Version (); + |; + + if ($@) { + if (defined $opt and $opt & $_INSTALL_DONT_DIE) { + $GT::JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)"; + return 0; + } + Carp::croak $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $GT::JSON::Backend = $Module_XS ); + my $data = join("", ); # this code is from Jcode 2.xx. + close(DATA); + eval $data; + GT::JSON::Backend::XS->init; + } + + return 1; +}; + + +sub _load_pp { + my $opt = shift; + + $GT::JSON::DEBUG and Carp::carp "Load $Module_PP."; + + # if called after install module, overload is disable.... why? + GT::JSON::Boolean::_overrride_overload($Module_XS); + GT::JSON::Boolean::_overrride_overload($Module_PP); + + eval qq| require $Module_PP |; + if ($@) { + Carp::croak $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $GT::JSON::Backend = $Module_PP ); + GT::JSON::Backend::PP->init; + } +}; + + +sub _set_module { + my $module = shift; + + local $^W; + no strict qw(refs); + + $GT::JSON::true = ${"$module\::true"}; + $GT::JSON::false = ${"$module\::false"}; + + push @GT::JSON::ISA, $module; + push @{"$module\::Boolean::ISA"}, qw(GT::JSON::Boolean); + + *{"GT::JSON::is_bool"} = \&{"$module\::is_bool"}; + + my $base = 'JSON'; + $base = "GT::$base" unless $module eq $Module_XS; + + for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) { + *{"$base::$method"} = sub { + Carp::carp("$method is not supported in $module."); + $_[0]; + }; + } + + return 1; +} + + + +# +# GT::JSON Boolean +# + +package GT::JSON::Boolean; + +my %Installed; + +sub _overrride_overload { + return if ($Installed{ $_[0] }++); + + my $boolean = $_[0] . '::Boolean'; + + eval sprintf(q| + package %s; + use overload ( + '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' }, + 'eq' => sub { + my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]); + if ($op eq 'true' or $op eq 'false') { + return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op; + } + else { + return $obj ? 1 == $op : 0 == $op; + } + }, + ); + |, $boolean); + + if ($@) { Carp::croak $@; } + + return 1; +} + + +# +# Helper classes for Backend Module (PP) +# + +package GT::JSON::Backend::PP; + +sub init { + local $^W; + no strict qw(refs); + *{"GT::JSON::decode_json"} = \&{"GT::JSON::PP::decode_json"}; + *{"GT::JSON::encode_json"} = \&{"GT::JSON::PP::encode_json"}; + *{"GT::JSON::PP::is_xs"} = sub { 0 }; + *{"GT::JSON::PP::is_pp"} = sub { 1 }; + return 1; +} + +# +# To save memory, the below lines are read only when XS backend is used. +# + +package GT::JSON; + +1; +__DATA__ + + +# +# Helper classes for Backend Module (XS) +# + +package GT::JSON::Backend::XS; + +use constant INDENT_LENGTH_FLAG => 15 << 12; + +use constant UNSUPPORTED_ENCODE_FLAG => { + ESCAPE_SLASH => 0x00000010, + ALLOW_BIGNUM => 0x00000020, + AS_NONBLESSED => 0x00000040, + EXPANDED => 0x10000000, # for developer's +}; + +use constant UNSUPPORTED_DECODE_FLAG => { + LOOSE => 0x00000001, + ALLOW_BIGNUM => 0x00000002, + ALLOW_BAREKEY => 0x00000004, + ALLOW_SINGLEQUOTE => 0x00000008, + EXPANDED => 0x20000000, # for developer's +}; + + +sub init { + local $^W; + no strict qw(refs); + *{"GT::JSON::decode_json"} = \&{"JSON::XS::decode_json"}; + *{"GT::JSON::encode_json"} = \&{"JSON::XS::encode_json"}; + *{"JSON::XS::is_xs"} = sub { 1 }; + *{"JSON::XS::is_pp"} = sub { 0 }; + return 1; +} + + +sub support_by_pp { + my ($class, @methods) = @_; + + local $^W; + no strict qw(refs); + + push @GT::JSON::Backend::XS::Supportable::ISA, 'GT::JSON'; + + my $pkg = 'GT::JSON::Backend::XS::Supportable'; + + *{GT::JSON::new} = sub { + my $proto = new JSON::XS; $$proto = 0; + bless $proto, $pkg; + }; + + for my $method (@methods) { + my $flag = uc($method); + my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0); + $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0); + + next unless($type); + + $pkg->_make_unsupported_method($method => $type); + } + + push @{"JSON::XS::Boolean::ISA"}, qw(GT::JSON::PP::Boolean); + push @{"GT::JSON::PP::Boolean::ISA"}, qw(GT::JSON::Boolean); + + $GT::JSON::DEBUG and Carp::carp("set -support_by_pp mode."); + + return 1; +} + + + + +# +# Helper classes for XS +# + +package GT::JSON::Backend::XS::Supportable; + + +my $JSON_XS_encode_orignal = \&JSON::XS::encode; +my $JSON_XS_decode_orignal = \&JSON::XS::decode; + +$Carp::Internal{'GT::JSON::Backend::XS::Supportable'} = 1; + +sub _make_unsupported_method { + my ($pkg, $method, $type) = @_; + + local $^W; + no strict qw(refs); + + *{"$pkg\::$method"} = sub { + local $^W; + if (defined $_[1] ? $_[1] : 1) { + ${$_[0]} |= $type; + } + else { + ${$_[0]} &= ~$type; + } + + if (${$_[0]}) { + *JSON::XS::encode = \>::JSON::Backend::XS::Supportable::_encode; + *JSON::XS::decode = \>::JSON::Backend::XS::Supportable::_decode; + } + else { + *JSON::XS::encode = $JSON_XS_encode_orignal; + *JSON::XS::decode = $JSON_XS_decode_orignal; + } + + $_[0]; + }; + + *{"$pkg\::get_$method"} = sub { + ${$_[0]} & $type ? 1 : ''; + }; + +} + + +sub _set_for_pp { + require GT::JSON::PP; + my $type = shift; + my $pp = new GT::JSON::PP; + my $prop = $_[0]->property; + + for my $name (keys %$prop) { + $pp->$name( $prop->{$name} ? $prop->{$name} : 0 ); + } + + my $unsupported = $type eq 'encode' ? GT::JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG + : GT::JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG; + my $flags = ${$_[0]} || 0; + + for my $name (keys %$unsupported) { + next if ($name eq 'EXPANDED'); # for developer's + my $enable = ($flags & $unsupported->{$name}) ? 1 : 0; + my $method = lc $name; + $pp->$method($enable); + } + + $pp->indent_length( $_[0]->get_indent_length ); + + return $pp; +} + + +sub _encode { # using with PP encod + _set_for_pp('encode' => @_)->encode($_[1]); +} + + +sub _decode { # if unsupported-flag is set, use PP + _set_for_pp('decode' => @_)->decode($_[1]); +} + + +sub decode_prefix { # if unsupported-flag is set, use PP + _set_for_pp('decode' => @_)->decode_prefix($_[1]); +} + + +sub get_indent_length { + ${$_[0]} << 4 >> 16; +} + + +sub indent_length { + my $length = $_[1]; + + if (!defined $length or $length > 15 or $length < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + local $^W; + $length <<= 12; + ${$_[0]} &= ~ GT::JSON::Backend::XS::INDENT_LENGTH_FLAG; + ${$_[0]} |= $length; + *JSON::XS::encode = \>::JSON::Backend::XS::Supportable::_encode; + } + + $_[0]; +} + + +1; +__END__ + +=head1 NAME + +GT::JSON - JSON (JavaScript Object Notation) encoder/decoder + +=head1 DISCLAIMER + +This module is based off of Makamaka Hannyaharamitu's JSON module (2.12). + +=head1 SYNOPSIS + + use GT::JSON; # imports encode_json, decode_json, to_json and from_json. + + $json_text = to_json($perl_scalar); + $perl_scalar = from_json($json_text); + + # option-acceptable + $json_text = to_json($perl_scalar, {ascii => 1}); + $perl_scalar = from_json($json_text, {utf8 => 1}); + + # OOP + $json = new GT::JSON; + + $json_text = $json->encode($perl_scalar); + $perl_scalar = $json->decode($json_text); + + # pretty-printing + $json_text = $json->pretty->encode($perl_scalar); + + # simple interface + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + + # If you want to use PP only support features, call with '-support_by_pp' + # When XS unsupported feature is enable, using PP de/encode. + + use GT::JSON -support_by_pp; + + +=head1 VERSION + + 2.14 + +This version is compatible with JSON::XS B<2.22> and later. + + +=head1 DESCRIPTION + +GT::JSON (JavaScript Object Notation) is a simple data format. +See to L and C(L). + +This module converts Perl data structures to JSON and vice versa using either +L or L. + +JSON::XS is the fastest and most proper JSON module on CPAN which must be +compiled and installed in your environment. +GT::JSON::PP is a pure-Perl module which is bundled in this distribution and +has a strong compatibility to JSON::XS. + +This module try to use JSON::XS by default and fail to it, use GT::JSON::PP instead. +So its features completely depend on JSON::XS or GT::JSON::PP. + +See to L. + +To distinguish the module name 'GT::JSON' and the format type JSON, +the former is quoted by CEE (its results vary with your using media), +and the latter is left just as it is. + +Module name : C + +Format type : JSON + +=head2 FEATURES + +=over + +=item * correct unicode handling + +This module (i.e. backend modules) knows how to handle Unicode, documents +how and when it does so, and even documents what "correct" means. + +Even though there are limitations, this feature is available since Perl version 5.6. + +JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions +C should call GT::JSON::PP as the backend which can be used since Perl 5.005. + +With Perl 5.8.x GT::JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem, +GT::JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available. +See to L for more information. + +See also to L +and L. + + +=item * round-trip integrity + +When you serialise a perl data structure using only data types supported by JSON, +the deserialised data structure is identical on the Perl level. +(e.g. the string "2.0" doesn't suddenly become "2" just because it looks +like a number). There minor I exceptions to this, read the MAPPING +section below to learn about those. + +=item * strict checking of JSON correctness + +There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default (the latter is a security +feature). + +See to L and L. + +=item * fast + +This module returns a JSON::XS object itself if avaliable. +Compared to other JSON modules and other serialisers such as Storable, +JSON::XS usually compares favourably in terms of speed, too. + +If not avaliable, C returns a GT::JSON::PP object instead of JSON::XS and +it is very slow as pure-Perl. + +=item * simple to use + +This module has both a simple functional interface as well as an +object oriented interface interface. + +=item * reasonably versatile output formats + +You can choose between the most compact guaranteed-single-line format possible +(nice for simple line-based protocols), a pure-ASCII format (for when your transport +is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed +format (for when you want to read that stuff). Or you can combine those features +in whatever way you like. + +=back + +=head1 FUNCTIONAL INTERFACE + +Some documents are copied and modified from L. +C and C are additional functions. + +=head2 to_json + + $json_text = to_json($perl_scalar) + +Converts the given Perl data structure to a json string. + +This function call is functionally identical to: + + $json_text = GT::JSON->new->encode($perl_scalar) + +Takes a hash reference as the second. + + $json_text = to_json($perl_scalar, $flag_hashref) + +So, + + $json_text = encode_json($perl_scalar, {utf8 => 1, pretty => 1}) + +equivalent to: + + $json_text = GT::JSON->new->utf8(1)->pretty(1)->encode($perl_scalar) + + +=head2 from_json + + $perl_scalar = from_json($json_text) + +The opposite of C: expects a json string and tries +to parse it, returning the resulting reference. + +This function call is functionally identical to: + + $perl_scalar = GT::JSON->decode($json_text) + +Takes a hash reference as the second. + + $perl_scalar = from_json($json_text, $flag_hashref) + +So, + + $perl_scalar = from_json($json_text, {utf8 => 1}) + +equivalent to: + + $perl_scalar = GT::JSON->new->utf8(1)->decode($json_text) + +=head2 encode_json + + $json_text = encode_json $perl_scalar + +Converts the given Perl data structure to a UTF-8 encoded, binary string. + +This function call is functionally identical to: + + $json_text = GT::JSON->new->utf8->encode($perl_scalar) + +=head2 decode_json + + $perl_scalar = decode_json $json_text + +The opposite of C: expects an UTF-8 (binary) string and tries +to parse that as an UTF-8 encoded JSON text, returning the resulting +reference. + +This function call is functionally identical to: + + $perl_scalar = GT::JSON->new->utf8->decode($json_text) + +=head2 GT::JSON::is_bool + + $is_boolean = GT::JSON::is_bool($scalar) + +Returns true if the passed scalar represents either GT::JSON::true or +GT::JSON::false, two constants that act like C<1> and C<0> respectively +and are also used to represent JSON C and C in Perl strings. + +=head2 GT::JSON::true + +Returns JSON true value which is blessed object. +It C GT::JSON::Boolean object. + +=head2 GT::JSON::false + +Returns JSON false value which is blessed object. +It C GT::JSON::Boolean object. + +=head2 GT::JSON::null + +Returns C. + +See L, below, for more information on how JSON values are mapped to +Perl. + +=head1 COMMON OBJECT-ORIENTED INTERFACE + + +=head2 new + + $json = new GT::JSON + +Returns a new C object inherited from either JSON::XS or GT::JSON::PP +that can be used to de/encode JSON strings. + +All boolean flags described below are by default I. + +The mutators for flags all return the JSON object again and thus calls can +be chained: + + my $json = GT::JSON->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + +=head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + +If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + +If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format. + +This feature depends on the used Perl version and environment. + +See to L if the backend is PP. + + GT::JSON->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + +=head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + +If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + +If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags. + + GT::JSON->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + +=head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + +If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + +In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627. + +If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + +Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); + +Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + +See to L if the backend is PP. + + +=head2 pretty + + $json = $json->pretty([$enable]) + +This enables (or disables) all of the C, C and +C (and in the future possibly more) flags in one call to +generate the most readable (or most compact) form possible. + +Equivalent to: + + $json->indent->space_before->space_after + +The indent space length is three and JSON::XS cannot change the indent +space length. + +=head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + +If C<$enable> is true (or missing), then the C method will use a multiline +format as output, putting every array member or object/hash key-value pair +into its own line, identing them properly. + +If C<$enable> is false, no newlines or indenting will be produced, and the +resulting JSON text is guarenteed not to contain any C. + +This setting has no effect when decoding JSON texts. + +The indent space length is three. +With GT::JSON::PP, you can also access C to change indent space length. + + +=head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + +If C<$enable> is true (or missing), then the C method will add an extra +optional space before the C<:> separating keys from values in JSON objects. + +If C<$enable> is false, then the C method will not add any extra +space at those places. + +This setting has no effect when decoding JSON texts. + +Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + +=head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + +If C<$enable> is true (or missing), then the C method will add an extra +optional space after the C<:> separating keys from values in JSON objects +and extra whitespace after the C<,> separating key-value pairs and array +members. + +If C<$enable> is false, then the C method will not add any extra +space at those places. + +This setting has no effect when decoding JSON texts. + +Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + +=head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + +If C<$enable> is true (or missing), then C will accept some +extensions to normal JSON syntax (see below). C will not be +affected in anyway. I. I suggest only to use this option to +parse application-specific files written by humans (configuration files, +resource files etc.) + +If C<$enable> is false (the default), then C will only accept +valid JSON texts. + +Currently accepted extensions are: + +=over 4 + +=item * list items can have an end-comma + +JSON I array elements and key-value pairs with commas. This +can be annoying if you write JSON texts manually and want to be able to +quickly append elements, so this extension accepts comma at the end of +such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + +=item * shell-style '#'-comments + +Whenever JSON allows whitespace, shell-style comments are additionally +allowed. They are terminated by the first carriage-return or line-feed +character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + +=back + + +=head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + +If C<$enable> is true (or missing), then the C method will output JSON objects +by sorting their keys. This is adding a comparatively high overhead. + +If C<$enable> is false, then the C method will output key-value +pairs in the order Perl stores them (which will likely change between runs +of the same script). + +This option is useful if you want the same data structure to be encoded as +the same JSON text (given the same overall settings). If it is disabled, +the same hash might be encoded differently even if contains the same data, +as key-value pairs have no inherent ordering in Perl. + +This setting has no effect when decoding JSON texts. + +=head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + +If C<$enable> is true (or missing), then the C method can convert a +non-reference into its corresponding string, number or null JSON value, +which is an extension to RFC4627. Likewise, C will accept those JSON +values instead of croaking. + +If C<$enable> is false, then the C method will croak if it isn't +passed an arrayref or hashref, as JSON texts must either be an object +or array. Likewise, C will croak if given something that is not a +JSON object or array. + + GT::JSON->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + +=head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + +If $enable is true (or missing), then "encode" will *not* throw an +exception when it encounters values it cannot represent in JSON (for +example, filehandles) but instead will encode a JSON "null" value. +Note that blessed objects are not included here and are handled +separately by c. + +If $enable is false (the default), then "encode" will throw an +exception when it encounters anything it cannot encode as JSON. + +This option does not affect "decode" in any way, and it is +recommended to leave it off unless you know your communications +partner. + +=head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + +If C<$enable> is true (or missing), then the C method will not +barf when it encounters a blessed reference. Instead, the value of the +B option will decide whether C (C +disabled or no C method found) or a representation of the +object (C enabled and C method found) is being +encoded. Has no effect on C. + +If C<$enable> is false (the default), then C will throw an +exception when it encounters a blessed object. + + +=head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + +If C<$enable> is true (or missing), then C, upon encountering a +blessed object, will check for the availability of the C method +on the object's class. If found, it will be called in scalar context +and the resulting scalar will be encoded instead of the object. If no +C method is found, the value of C will decide what +to do. + +The C method may safely call die if it wants. If C +returns other blessed objects, those will be handled in the same +way. C must take care of not causing an endless recursion cycle +(== crash) in this case. The name of C was chosen because other +methods called by the Perl core (== not by the user of the object) are +usually in upper case letters and to avoid collisions with the C +function or method. + +This setting does not yet influence C in any way. + +If C<$enable> is false, then the C setting will decide what +to do when a blessed object is found. + +=over + +=item convert_blessed_universally mode + +If use C with C<-convert_blessed_universally>, the C +subroutine is defined as the below code: + + *UNIVERSAL::TO_JSON = sub { + my $b_obj = B::svref_2object( $_[0] ); + return $b_obj->isa('B::HV') ? { %{ $_[0] } } + : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] + : undef + ; + } + +This will cause that C method converts simple blessed objects into +JSON objects as non-blessed object. + + JSON -convert_blessed_universally; + $json->allow_blessed->convert_blessed->encode( $blessed_object ) + +This feature is experimental and may be removed in the future. + +=back + +=head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + +When C<$coderef> is specified, it will be called from C each +time it decodes a JSON object. The only argument passed to the coderef +is a reference to the newly-created hash. If the code references returns +a single scalar (which need not be a reference), this value +(i.e. a copy of that scalar to avoid aliasing) is inserted into the +deserialised data structure. If it returns an empty list +(NOTE: I C, which is a valid scalar), the original deserialised +hash will be inserted. This setting can slow down decoding considerably. + +When C<$coderef> is omitted or undefined, any existing callback will +be removed and C will not change the deserialised hash in any +way. + +Example, convert all JSON objects into the integer 5: + + my $js = GT::JSON->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]'); # the given subroutine takes a hash reference. + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + + +=head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + +Works remotely similar to C, but is only called for +JSON objects having a single key named C<$key>. + +This C<$coderef> is called before the one specified via +C, if any. It gets passed the single value in the JSON +object. If it returns a single value, it will be inserted into the data +structure. If it returns nothing (not even C but the empty list), +the callback from C will be called next, as if no +single-key callback were specified. + +If C<$coderef> is omitted or undefined, the corresponding callback will be +disabled. There can only ever be one callback for a given key. + +As this callback gets called less often then the C +one, decoding speed will not usually suffer as much. Therefore, single-key +objects make excellent targets to serialise Perl objects into, especially +as single-key JSON objects are as close to the type-tagged value concept +as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not +support this in any way, so you need to make sure your data never looks +like a serialised Perl hash. + +Typical names for the single object key are C<__class_whatever__>, or +C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even +things like C<__class_md5sum(classname)__>, to reduce the risk of clashing +with real hashes. + +Example, decode JSON objects of the form C<< { "__widget__" => } >> +into the corresponding C<< $WIDGET{} >> object: + + # return whatever is in $WIDGET{5}: + GT::JSON + ->new + ->filter_json_single_key_object (__widget__ => sub { + $WIDGET{ $_[0] } + }) + ->decode ('{"__widget__": 5') + + # this can be used with a TO_JSON method in some "widget" class + # for serialisation to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + + +=head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + +With JSON::XS, this flag resizes strings generated by either +C or C to their minimum size possible. This can save +memory when your JSON texts are either very very long or you have many +short strings. It will also try to downgrade any strings to octet-form +if possible: perl stores strings internally either in an encoding called +UTF-X or in octet-form. The latter cannot store everything but uses less +space in general (and some buggy Perl or C code might even rely on that +internal representation being used). + +With GT::JSON::PP, it is noop about resizing strings but tries +C to the returned string by C. See to L. + +See to L and L. + +=head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + +Sets the maximum nesting level (default C<512>) accepted while encoding +or decoding. If a higher nesting level is detected in JSON text or a Perl +data structure, then the encoder and decoder will stop and croak at that +point. + +Nesting level is defined by number of hash- or arrayrefs that the encoder +needs to traverse to reach a given point or the number of C<{> or C<[> +characters without their matching closing parenthesis crossed to reach a +given character in a string. + +If no argument is given, the highest possible setting will be used, which +is rarely useful. + +Note that nesting is implemented by recursion in C. The default value has +been chosen to be as large as typical operating systems allow without +crashing. (JSON::XS) + +With GT::JSON::PP as the backend, when a large value (100 or more) was set and +it de/encodes a deep nested object/text, it may raise a warning +'Deep recursion on subroutin' at the perl runtime phase. + +See L for more info on why this is useful. + +=head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + +Set the maximum length a JSON text may have (in bytes) where decoding is +being attempted. The default is C<0>, meaning no limit. When C +is called on a string that is longer then this many bytes, it will not +attempt to decode the string but throw an exception. This setting has no +effect on C (yet). + +If no argument is given, the limit check will be deactivated (same as when +C<0> is specified). + +See L, below, for more info on why this is useful. + +=head2 encode + + $json_text = $json->encode($perl_scalar) + +Converts the given Perl data structure (a simple scalar or a reference +to a hash or array) to its JSON representation. Simple scalars will be +converted into JSON string or number sequences, while references to arrays +become JSON arrays and references to hashes become JSON objects. Undefined +Perl values (e.g. C) become JSON C values. +References to the integers C<0> and C<1> are converted into C and C. + +=head2 decode + + $perl_scalar = $json->decode($json_text) + +The opposite of C: expects a JSON text and tries to parse it, +returning the resulting simple scalar or reference. Croaks on error. + +JSON numbers and strings become simple Perl scalars. JSON arrays become +Perl arrayrefs and JSON objects become Perl hashrefs. C becomes +C<1> (C), C becomes C<0> (C) and +C becomes C. + +=head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + +This works like the C method, but instead of raising an exception +when there is trailing garbage after the first JSON object, it will +silently stop parsing there and return the number of characters consumed +so far. + + GT::JSON->new->decode_prefix ("[1] the tail") + => ([], 3) + +See to L + +=head2 property + + $boolean = $json->property($property_name) + +Returns a boolean value about above some properties. + +The available properties are C, C, C, +C,C, C, C, C, +C, C, C, C, +C, C and C. + + $boolean = $json->property('utf8'); + => 0 + $json->utf8; + $boolean = $json->property('utf8'); + => 1 + +Sets the propery with a given boolean value. + + $json = $json->property($property_name => $boolean); + +With no argumnt, it returns all the above properties as a hash reference. + + $flag_hashref = $json->property(); + +=head1 INCREMENTAL PARSING + +In JSON::XS 2.2, incremental parsing feature of JSON texts was implemented. +Please check to L. + +=over 4 + +=item [void, scalar or list context] = $json->incr_parse ([$string]) + +This is the central parsing function. It can both append new text and +extract objects from the stream accumulated so far (both of these +functions are optional). + +If C<$string> is given, then this string is appended to the already +existing JSON fragment stored in the C<$json> object. + +After that, if the function is called in void context, it will simply +return without doing anything further. This can be used to add more text +in as many chunks as you want. + +If the method is called in scalar context, then it will try to extract +exactly I JSON object. If that is successful, it will return this +object, otherwise it will return C. If there is a parse error, +this method will croak just as C would do (one can then use +C to skip the errornous part). This is the most common way of +using the method. + +And finally, in list context, it will try to extract as many objects +from the stream as it can find and return them, or the empty list +otherwise. For this to work, there must be no separators between the JSON +objects or arrays, instead they must be concatenated back-to-back. If +an error occurs, an exception will be raised as in the scalar context +case. Note that in this case, any previously-parsed JSON texts will be +lost. + +=item $lvalue_string = $json->incr_text + +This method returns the currently stored JSON fragment as an lvalue, that +is, you can manipulate it. This I works when a preceding call to +C in I successfully returned an object. Under +all other circumstances you must not call this function (I mean it. +although in simple tests it might actually work, it I fail under +real world conditions). As a special exception, you can also call this +method before having parsed anything. + +This function is useful in two cases: a) finding the trailing text after a +JSON object or b) parsing multiple JSON objects separated by non-JSON text +(such as commas). + +In Perl 5.005, C attribute is not available. +You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + +=item $json->incr_skip + +This will reset the state of the incremental parser and will remove the +parsed text from the input buffer. This is useful after C +died, in which case the input buffer and incremental parser state is left +unchanged, to skip the text parsed so far and to reset the parse state. + +=item $json->incr_reset + +This completely resets the incremental parser, that is, after this call, +it will be as if the parser had never parsed anything. + +This is useful if you want ot repeatedly parse JSON objects and want to +ignore any trailing data, which means you have to reset the parser after +each successful decode. + +=back + +=head1 GT::JSON::PP SUPPORT METHODS + +The below methods are GT::JSON::PP own methods, so when C works +with GT::JSON::PP (i.e. the created object is a GT::JSON::PP object), available. +See to L in detail. + +If you use C with additonal C<-support_by_pp>, some methods +are available even with JSON::XS. See to L. + + BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' } + + use GT::JSON -support_by_pp; + + my $json = new GT::JSON; + $json->allow_nonref->escape_slash->encode("/"); + + # functional interfaces too. + print to_json(["/"], {escape_slash => 1}); + print from_json('["foo"]', {utf8 => 1}); + +If you do not want to all functions but C<-support_by_pp>, +use C<-no_export>. + + use GT::JSON -support_by_pp, -no_export; + # functional interfaces are not exported. + +=head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + +If C<$enable> is true (or missing), then C will accept +any JSON strings quoted by single quotations that are invalid JSON +format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + +As same as the C option, this option may be used to parse +application-specific files written by humans. + +=head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + +If C<$enable> is true (or missing), then C will accept +bare keys of JSON object that are invalid JSON format. + +As same as the C option, this option may be used to parse +application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + +=head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + +If C<$enable> is true (or missing), then C will convert +the big integer Perl cannot handle as integer into a L +object and convert a floating number (any) into a L. + +On the contary, C converts C objects and C +objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + +See to L aboout the conversion of JSON number. + +=head2 loose + + $json = $json->loose([$enable]) + +The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings +and the module doesn't allow to C to these (except for \x2f). +If C<$enable> is true (or missing), then C will accept these +unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + +See to L. + +=head2 escape_slash + + $json = $json->escape_slash([$enable]) + +According to JSON Grammar, I (U+002F) is escaped. But by default +JSON backend modules encode strings without escaping slash. + +If C<$enable> is true (or missing), then C will escape slashes. + +=head2 indent_length + + $json = $json->indent_length($length) + +With JSON::XS, The indent space length is 3 and cannot be changed. +With GT::JSON::PP, it sets the indent space length with the given $length. +The default is 3. The acceptable range is 0 to 15. + +=head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + +If $function_name or $subroutine_ref are set, its sort routine are used. + + $js = $pc->sort_by(sub { $GT::JSON::PP::a cmp $GT::JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub GT::JSON::PP::own_sort { $GT::JSON::PP::a cmp $GT::JSON::PP::b } + +As the sorting routine runs in the GT::JSON::PP scope, the given +subroutine name and the special variables C<$a>, C<$b> will begin +with 'GT::JSON::PP::'. + +If $integer is set, then the effect is same as C on. + +See to L. + +=head1 MAPPING + +This section is copied from JSON::XS and modified to C. +JSON::XS and GT::JSON::PP mapping mechanisms are almost equivalent. + +See to L. + +=head2 JSON -> PERL + +=over 4 + +=item object + +A JSON object becomes a reference to a hash in Perl. No ordering of object +keys is preserved (JSON does not preserver object key ordering itself). + +=item array + +A JSON array becomes a reference to an array in Perl. + +=item string + +A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON +are represented by the same codepoints in the Perl string, so no manual +decoding is necessary. + +=item number + +A JSON number becomes either an integer, numeric (floating point) or +string scalar in perl, depending on its range and any fractional parts. On +the Perl level, there is no difference between those as Perl handles all +the conversion details, but an integer may take slightly less memory and +might represent more values exactly than floating point numbers. + +If the number consists of digits only, C will try to represent +it as an integer value. If that fails, it will try to represent it as +a numeric (floating point) value if that is possible without loss of +precision. Otherwise it will preserve the number as a string value (in +which case you lose roundtripping ability, as the JSON number will be +re-encoded toa JSON string). + +Numbers containing a fractional or exponential part will always be +represented as numeric (floating point) values, possibly at a loss of +precision (in which case you might lose perfect roundtripping ability, but +the JSON number will still be re-encoded as a JSON number). + +If the backend is GT::JSON::PP and C is enable, the big integers +and the numeric can be optionally converted into L and +L objects. + +=item true, false + +These JSON atoms become C and C, +respectively. They are overloaded to act almost exactly like the numbers +C<1> and C<0>. You can check wether a scalar is a JSON boolean by using +the C function. + +If C and C are used as strings or compared as strings, +they represent as C and C respectively. + + print GT::JSON::true . "\n"; + => true + print GT::JSON::true + 1; + => 1 + + ok(GT::JSON::true eq 'true'); + ok(GT::JSON::true eq '1'); + ok(GT::JSON::true == 1); + +C will install these missing overloading features to the backend modules. + + +=item null + +A JSON null atom becomes C in Perl. + +C returns C. + +=back + + +=head2 PERL -> JSON + +The mapping from Perl to JSON is slightly more difficult, as Perl is a +truly typeless language, so we can only guess which JSON type is meant by +a Perl value. + +=over 4 + +=item hash references + +Perl hash references become JSON objects. As there is no inherent ordering +in hash keys (or JSON objects), they will usually be encoded in a +pseudo-random order that can change between runs of the same program but +stays generally the same within a single run of a program. C +optionally sort the hash keys (determined by the I flag), so +the same datastructure will serialise to the same JSON text (given same +settings and version of JSON::XS), but this incurs a runtime overhead +and is only rarely useful, e.g. when you want to compare some JSON text +against another for equality. + +In future, the ordered object feature will be added to GT::JSON::PP using C mechanism. + + +=item array references + +Perl array references become JSON arrays. + +=item other references + +Other unblessed references are generally not allowed and will cause an +exception to be thrown, except for references to the integers C<0> and +C<1>, which get turned into C and C atoms in JSON. You can +also use C and C to improve readability. + + to_json [\0,GT::JSON::true] # yields [false,true] + +=item GT::JSON::true, GT::JSON::false, GT::JSON::null + +These special values become JSON true and JSON false values, +respectively. You can also use C<\1> and C<\0> directly if you want. + +GT::JSON::null returns C. + +=item blessed objects + +Blessed objects are not directly representable in JSON. See the +C and C methods on various options on +how to deal with this: basically, you can choose between throwing an +exception, encoding the reference as if it weren't blessed, or provide +your own serialiser method. + +With C mode, C converts blessed +hash references or blessed array references (contains other blessed references) +into JSON members and arrays. + + use GT::JSON -convert_blessed_universally; + GT::JSON->new->allow_blessed->convert_blessed->encode( $blessed_object ); + +See to L. + +=item simple scalars + +Simple Perl scalars (any scalar that is not a reference) are the most +difficult objects to encode: JSON::XS and GT::JSON::PP will encode undefined scalars as +JSON C values, scalars that have last been used in a string context +before encoding as JSON strings, and anything else as number value: + + # dump as number + encode_json [2] # yields [2] + encode_json [-3.0e17] # yields [-3e+17] + my $value = 5; encode_json [$value] # yields [5] + + # used as string, so dump as string + print $value; + encode_json [$value] # yields ["5"] + + # undef becomes null + encode_json [undef] # yields [null] + +You can force the type to be a string by stringifying it: + + my $x = 3.1; # some variable containing a number + "$x"; # stringified + $x .= ""; # another, more awkward way to stringify + print $x; # perl does it for you, too, quite often + +You can force the type to be a number by numifying it: + + my $x = "3"; # some variable containing a string + $x += 0; # numify it, ensuring it will be dumped as a number + $x *= 1; # same thing, the choise is yours. + +You can not currently force the type in other, less obscure, ways. + +=item Big Number + +If the backend is GT::JSON::PP and C is enable, +C converts C objects and C +objects into JSON numbers. + + +=back + +=head1 JSON and ECMAscript + +See to L. + +=head1 JSON and YAML + +JSON is not a subset of YAML. +See to L. + + +=head1 BACKEND MODULE DECISION + +When you use C, C tries to C JSON::XS. If this call failed, it will +C GT::JSON::PP. The required JSON::XS version is I<2.2> or later. + +The C constructor method returns an object inherited from the backend module, +and JSON::XS object is a blessed scaler reference while GT::JSON::PP is a blessed hash +reference. + +So, your program should not depend on the backend module, especially +returned objects should not be modified. + + my $json = GT::JSON->new; # XS or PP? + $json->{stash} = 'this is xs object'; # this code may raise an error! + +To check the backend module, there are some methods - C, C and C. + + GT::JSON->backend; # 'JSON::XS' or 'GT::JSON::PP' + + GT::JSON->backend->is_pp: # 0 or 1 + + GT::JSON->backend->is_xs: # 1 or 0 + + $json->is_xs; # 1 or 0 + + $json->is_pp; # 0 or 1 + + +If you set an enviornment variable C, The calling action will be changed. + +=over + +=item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'GT::JSON::PP' + +Always use GT::JSON::PP + +=item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,GT::JSON::PP' + +(The default) Use compiled JSON::XS if it is properly compiled & installed, +otherwise use GT::JSON::PP. + +=item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS' + +Always use compiled JSON::XS, die if it isn't properly compiled & installed. + +=back + +These ideas come from L mechanism. + +example: + + BEGIN { $ENV{PERL_JSON_BACKEND} = 'GT::JSON::PP' } + use GT::JSON; # always uses GT::JSON::PP + +In future, it may be able to specify another module. + +=head1 USE PP FEATURES EVEN THOUGH XS BACKEND + +Many methods are available with either JSON::XS or GT::JSON::PP and +when the backend module is JSON::XS, if any GT::JSON::PP specific (i.e. JSON::XS unspported) +method is called, it will C and be noop. + +But If you C C passing the optional string C<-support_by_pp>, +it makes a part of those unupported methods available. +This feature is achieved by using GT::JSON::PP in C. + + BEING { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS + use GT::JSON -support_by_pp; + my $json = new GT::JSON; + $json->allow_nonref->escape_slash->encode("/"); + +At this time, the returned object is a C +object (re-blessed XS object), and by checking JSON::XS unsupported flags +in de/encoding, can support some unsupported methods - C, C, +C, C, C, C +and C. + +When any unsupported methods are not enable, C will be +used as is. The switch is achieved by changing the symbolic tables. + +C<-support_by_pp> is effective only when the backend module is GT::JSON::XS +and it makes the de/encoding speed down a bit. + +See to L. + +=head1 TODO + +=over + +=item example programs + +=back + +=head1 THREADS + +No test with GT::JSON::PP. If with JSON::XS, See to L. + + +=head1 BUGS + +Please report bugs relevant to C to Emakamaka[at]cpan.orgE. + + +=head1 SEE ALSO + +Most of the document is copied and modified from JSON::XS doc. + +L, L + +C(L) + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + +JSON::XS was written by Marc Lehmann + +The relese of this new version owes to the courtesy of Marc Lehmann. + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2005-2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP.pm new file mode 100644 index 0000000..ab75d3f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP.pm @@ -0,0 +1,2128 @@ +package GT::JSON::PP; + +# GT::JSON-2.0 + +use 5.005; +use strict; +use base qw(Exporter); +use overload; + +use Carp (); +use B (); +#use Devel::Peek; + +$GT::JSON::PP::VERSION = '2.22010'; + +@GT::JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + +# instead of hash-access, i tried index-access for speed. +# but this method is not faster than what i expected. so it will be changed. + +use constant P_ASCII => 0; +use constant P_LATIN1 => 1; +use constant P_UTF8 => 2; +use constant P_INDENT => 3; +use constant P_CANONICAL => 4; +use constant P_SPACE_BEFORE => 5; +use constant P_SPACE_AFTER => 6; +use constant P_ALLOW_NONREF => 7; +use constant P_SHRINK => 8; +use constant P_ALLOW_BLESSED => 9; +use constant P_CONVERT_BLESSED => 10; +use constant P_RELAXED => 11; + +use constant P_LOOSE => 12; +use constant P_ALLOW_BIGNUM => 13; +use constant P_ALLOW_BAREKEY => 14; +use constant P_ALLOW_SINGLEQUOTE => 15; +use constant P_ESCAPE_SLASH => 16; +use constant P_AS_NONBLESSED => 17; + +use constant P_ALLOW_UNKNOWN => 18; + +BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enable? + # Helper module sets @GT::JSON::PP::_properties. + + my $helper = $] >= 5.008 ? 'GT::JSON::PP58' + : $] >= 5.006 ? 'GT::JSON::PP56' + : 'GT::JSON::PP5005' + ; + + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $flag_name = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$flag_name] = 1; + } + else { + \$_[0]->{PROPS}->[$flag_name] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; + } + /; + } + +} + + + +# Functions + +my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash + allow_blessed convert_blessed indent indent_length allow_bignum + as_nonblessed + /; +my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum + allow_barekey max_size relaxed/; + + +my $JSON; # cache + +sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); +} + + +sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); +} + +# Obsoleted + +sub to_json($) { + Carp::croak ("GT::JSON::PP::to_json has been renamed to encode_json."); +} + + +sub from_json($) { + Carp::croak ("GT::JSON::PP::from_json has been renamed to decode_json."); +} + + +# Methods + +sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent => 0, + FLAGS => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + indent_length => 3, + }; + + bless $self, $class; +} + + +sub encode { + return $_[0]->PP_encode_json($_[1]); +} + + +sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); +} + + +sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); +} + + +# accessor + + +# pretty printing + +sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; +} + +# etc + +sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; +} + + +sub get_max_depth { $_[0]->{max_depth}; } + + +sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; +} + + +sub get_max_size { $_[0]->{max_size}; } + + +sub filter_json_object { + $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub filter_json_single_key_object { + if (@_ > 1) { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; +} + +sub get_indent_length { + $_[0]->{indent_length}; +} + +sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; +} + +sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); +} + +############################### + +### +### Perl => JSON +### + + +{ # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $idx = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed) + = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($idx->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('GT::JSON::PP::Boolean') ); + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and $obj eq $result ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. + + encode_error( sprintf("encountered object '%s', but neither allow_blessed " + . "nor convert_blessed settings are enabled", $obj) + ) unless ($allow_blessed); + + return 'null'; + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + if ( my $tie_class = tied %$obj ) { + if ( $tie_class->can('TIEHASH') ) { + $tie_class =~ s/=.+$//; + tie %res, $tie_class; + } + } + + # In the old Perl verions, tied hashes in bool context didn't work. + # So, we can't use such a way (%res ? a : b) + my $has; + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->object_to_json($v) || $self->value_to_json($v); + $has = 1 unless ( $has ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{' . ( $has ? $pre : '' ) # indent + . ( $has ? join(",$pre", map { utf8::decode($_) if ($] < 5.008); # key for Perl 5.6 + string_to_json($self, $_) . $del . $res{$_} # key : value + } _sort( $self, \%res ) + ) . $post # indent + : '' + ) + . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + if (my $tie_class = tied @$obj) { + if ( $tie_class->can('TIEARRAY') ) { + $tie_class =~ s/=.+$//; + tie @res, $tie_class; + } + } + + for my $v (@$obj){ + push @res, $self->object_to_json($v) || $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; + } + + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + my $flags = $b_obj->FLAGS; + + return $value # as is + if ( ( $flags & B::SVf_IOK or $flags & B::SVp_IOK + or $flags & B::SVf_NOK or $flags & B::SVp_NOK + ) and !($flags & B::SVf_POK ) + ); # SvTYPE is IV or NV? + + my $type = ref($value); + + if(!$type){ + return string_to_json($self, $value); + } + elsif( blessed($value) and $value->isa('GT::JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $b_obj = B::svref_2object($_[1]); + if ($b_obj->isa('B::HV')) { + return $_[0]->hash_to_json($_[1]); + } + elsif ($b_obj->isa('B::AV')) { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + my ($self, $res) = @_; + defined $keysort ? (sort $keysort (keys %$res)) : keys %$res; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + +} # Convert + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); +} + + +sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); +} + + + +# +# JSON => Perl +# + +my $max_intsize; + +BEGIN { + my $checkint = 1111; + for my $d (5..30) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } +} + +{ # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest nubmer of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bigint; # using Math::BigInt + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + + sub PP_decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if (!defined $text or ref $text) { + decode_error("malformed text data."); + } + + my $idx = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) + = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; + + if ( $utf8 ) { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + else { + utf8::upgrade( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + # Currently no effect + # should use regexp + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + my $result = value(); + + if (!$idx->[ P_ALLOW_NONREF ] and !ref $result) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + if ($len >= $at) { + my $consumed = $at - 1; + white(); + if ($ch) { + decode_error("garbage after JSON object") unless ($opt & 0x00000001); + return ($result, $consumed); + } + } + + $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my ($i, $s, $t, $u); + my $utf16; + my $is_utf8; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch if ($singlequote); + + OUTER: while( defined(next_chr()) ){ + + if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ( ( my $hex = hex( $u ) ) > 127 ) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + + if ( ord $ch > 127 ) { + if ( $utf8 ) { + unless( $ch = is_valid_utf8($ch) ) { + $at -= 1; + decode_error("malformed UTF-8 character in JSON string"); + } + else { + $at += $utf8_len - 1; + } + } + else { + utf8::encode( $ch ); + } + + $is_utf8 = 1; + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = []; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub object { + my $o = {}; + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at--; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $GT::JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $GT::JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + decode_error("malformed number (leading zero must not be followed by another digit)"); + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + if (defined $n and length $n > 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($v !~ /[.eE]/ and length $v > $max_intsize) { + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + elsif ($allow_bigint) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + + return 0+$v; + } + + + sub is_valid_utf8 { + + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + + return unless $utf8_len; + + my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); + + return ( $is_valid_utf8 =~ /^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$/x ) ? $is_valid_utf8 : ''; + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = $] >= 5.008 ? 'U*' + : $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at [\"$mess\"]" + ); + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 1) { + return $val[0]; + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0 or @val > 1) { + return $o; + } + else { + return $val[0]; + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + +} # PARSE + + +sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + my $un = pack('U*', $uni); + utf8::encode( $un ); + return $un; +} + + +sub _decode_unicode { + my $un = pack('U', hex shift); + utf8::encode( $un ); + return $un; +} + + + + + +############################### +# Utilities +# + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *GT::JSON::PP::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *GT::JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } +} + + +# shamely copied and modified from JSON::XS code. + +$GT::JSON::PP::true = do { bless \(my $dummy = 1), "GT::JSON::PP::Boolean" }; +$GT::JSON::PP::false = do { bless \(my $dummy = 0), "GT::JSON::PP::Boolean" }; + +sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "GT::JSON::PP::Boolean"); } + +sub true { $GT::JSON::PP::true } +sub false { $GT::JSON::PP::false } +sub null { undef; } + +############################### + +package GT::JSON::PP::Boolean; + + +use overload ( + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, +); + + +############################### + +package GT::JSON::PP::IncrParser; + +use strict; + +use constant INCR_M_WS => 0; # initial whitespace skipping +use constant INCR_M_STR => 1; # inside string +use constant INCR_M_BS => 2; # inside backslash +use constant INCR_M_JSON => 3; # outside anything, count nesting + +$GT::JSON::PP::IncrParser::VERSION = '1.01'; + +my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; + +sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_parsing => 0, + incr_p => 0, + + }, $class; +} + + +sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + + my $max_size = $coder->get_max_size; + + if ( defined wantarray ) { + + $self->{incr_mode} = INCR_M_WS; + + if ( wantarray ) { + my @ret; + + $self->{incr_parsing} = 1; + + do { + push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); + + unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { + $self->{incr_mode} = INCR_M_WS; + } + + } until ( !$self->{incr_text} ); + + $self->{incr_parsing} = 0; + + return @ret; + } + else { # in scalar context + $self->{incr_parsing} = 1; + my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); + $self->{incr_parsing} = 0; + return $obj; + } + + } + +} + + +sub _incr_parse { + my ( $self, $coder, $text, $skip ) = @_; + my $p = $self->{incr_p}; + my $restore = $p; + + my @obj; + my $len = length $text; + + if ( $self->{incr_mode} == INCR_M_WS ) { + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); + $self->{incr_mode} = INCR_M_JSON; + last; + } + } + + while ( $len > $p ) { + my $s = substr( $text, $p++, 1 ); + + if ( $s eq '"' ) { + if ( $self->{incr_mode} != INCR_M_STR ) { + $self->{incr_mode} = INCR_M_STR; + } + else { + $self->{incr_mode} = INCR_M_JSON; + unless ( $self->{incr_nest} ) { + last; + } + } + } + + if ( $self->{incr_mode} == INCR_M_JSON ) { + + if ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + } + elsif ( $s eq ']' or $s eq '}' ) { + last if ( --$self->{incr_nest} <= 0 ); + } + } + + } + + $self->{incr_p} = $p; + + return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); + + return unless ( length substr( $self->{incr_text}, 0, $p ) ); + + local $Carp::CarpLevel = 2; + + $self->{incr_p} = $restore; + $self->{incr_c} = $p; + + my ( $obj, $tail ) = $coder->decode_prefix( substr( $self->{incr_text}, 0, $p ) ); + + $self->{incr_text} = substr( $self->{incr_text}, $p ); + $self->{incr_p} = 0; + + return $obj; +} + + +sub incr_text { + if ( $_[0]->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; +} + + +sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); + $self->{incr_p} = 0; +} + + +sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_p} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; + $self->{incr_parsing} = 0; +} + +############################### + + +1; +__END__ +=pod + +=head1 NAME + +GT::JSON::PP - JSON::XS compatible pure-Perl module. + +=head1 SYNOPSIS + + use GT::JSON::PP; + + # exported functions, they croak on error + # and expect/generate UTF-8 + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $coder = GT::JSON::PP->new->ascii->pretty->allow_nonref; + $pretty_printed_unencoded = $coder->encode ($perl_scalar); + $perl_scalar = $coder->decode ($unicode_json_text); + + # Note that GT::JSON version 2.0 and above will automatically use + # JSON::XS or GT::JSON::PP, so you should be able to just: + + use GT::JSON; + +=head1 DESCRIPTION + +This module is L compatible pure Perl module. +(Perl 5.8 or later is recommended) + +JSON::XS is the fastest and most proper JSON module on CPAN. +It is written by Marc Lehmann in C, so must be compiled and +installed in the used environment. + +GT::JSON::PP is a pure-Perl module and has compatibility to JSON::XS. + + +=head2 FEATURES + +=over + +=item * correct unicode handling + +This module knows how to handle Unicode (depending on Perl version). + +See to L and L. + + +=item * round-trip integrity + +When you serialise a perl data structure using only datatypes supported by JSON, +the deserialised data structure is identical on the Perl level. +(e.g. the string "2.0" doesn't suddenly become "2" just because it looks like a number). + +=item * strict checking of JSON correctness + +There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default (the latter is a security feature). +But when some options are set, loose chcking features are available. + +=back + +=head1 FUNCTIONS + +Basically, check to L or L. + +=head2 encode_json + + $json_text = encode_json $perl_scalar + +=head2 decode_json + + $perl_scalar = decode_json $json_text + +=head2 GT::JSON::PP::true + +Returns JSON true value which is blessed object. +It C GT::JSON::PP::Boolean object. + +=head2 GT::JSON::PP::false + +Returns JSON false value which is blessed object. +It C GT::JSON::PP::Boolean object. + +=head2 GT::JSON::PP::null + +Returns C. + +=head1 METHODS + +Basically, check to L or L. + +=head2 new + + $json = new GT::JSON::PP + +Rturns a new GT::JSON::PP object that can be used to de/encode JSON +strings. + +=head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + +If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. +(See to L). + +In Perl 5.005, there is no character having high value (more than 255). +See to L. + +If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format. + + GT::JSON::PP->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + +=head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + +If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + +If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags. + + JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + +See to L. + +=head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + +If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + +(In Perl 5.005, any character outside the range 0..255 does not exist. +See to L.) + +In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627. + +If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + +Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); + +Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + + +=head2 pretty + + $json = $json->pretty([$enable]) + +This enables (or disables) all of the C, C and +C flags in one call to generate the most readable +(or most compact) form possible. + +=head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + +The default indent space lenght is three. +You can use C to change the length. + +=head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + +=head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + +=head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + +=head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + +If you want your own sorting routine, you can give a code referece +or a subroutine name to C. See to C. + +=head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + +=head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + +=head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + +=head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + +=head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + +=head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + +=head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + +In JSON::XS, this flag resizes strings generated by either +C or C to their minimum size possible. +It will also try to downgrade any strings to octet-form if possible. + +In GT::JSON::PP, it is noop about resizing strings but tries +C to the returned string by C. +See to L. + +See to L + +=head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + +Sets the maximum nesting level (default C<512>) accepted while encoding +or decoding. If a higher nesting level is detected in JSON text or a Perl +data structure, then the encoder and decoder will stop and croak at that +point. + +Nesting level is defined by number of hash- or arrayrefs that the encoder +needs to traverse to reach a given point or the number of C<{> or C<[> +characters without their matching closing parenthesis crossed to reach a +given character in a string. + +If no argument is given, the highest possible setting will be used, which +is rarely useful. + +See L for more info on why this is useful. + +When a large value (100 or more) was set and it de/encodes a deep nested object/text, +it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. + +=head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + +Set the maximum length a JSON text may have (in bytes) where decoding is +being attempted. The default is C<0>, meaning no limit. When C +is called on a string that is longer then this many bytes, it will not +attempt to decode the string but throw an exception. This setting has no +effect on C (yet). + +If no argument is given, the limit check will be deactivated (same as when +C<0> is specified). + +See L for more info on why this is useful. + +=head2 encode + + $json_text = $json->encode($perl_scalar) + +=head2 decode + + $perl_scalar = $json->decode($json_text) + +=head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + + +=head1 INCREMENTAL PARSING + +In JSON::XS 2.2, incremental parsing feature of JSON +texts was experimentally implemented. +Please check to L. + +=over 4 + +=item [void, scalar or list context] = $json->incr_parse ([$string]) + +This is the central parsing function. It can both append new text and +extract objects from the stream accumulated so far (both of these +functions are optional). + +If C<$string> is given, then this string is appended to the already +existing JSON fragment stored in the C<$json> object. + +After that, if the function is called in void context, it will simply +return without doing anything further. This can be used to add more text +in as many chunks as you want. + +If the method is called in scalar context, then it will try to extract +exactly I JSON object. If that is successful, it will return this +object, otherwise it will return C. If there is a parse error, +this method will croak just as C would do (one can then use +C to skip the errornous part). This is the most common way of +using the method. + +And finally, in list context, it will try to extract as many objects +from the stream as it can find and return them, or the empty list +otherwise. For this to work, there must be no separators between the JSON +objects or arrays, instead they must be concatenated back-to-back. If +an error occurs, an exception will be raised as in the scalar context +case. Note that in this case, any previously-parsed JSON texts will be +lost. + +=item $lvalue_string = $json->incr_text + +This method returns the currently stored JSON fragment as an lvalue, that +is, you can manipulate it. This I works when a preceding call to +C in I successfully returned an object. Under +all other circumstances you must not call this function (I mean it. +although in simple tests it might actually work, it I fail under +real world conditions). As a special exception, you can also call this +method before having parsed anything. + +This function is useful in two cases: a) finding the trailing text after a +JSON object or b) parsing multiple JSON objects separated by non-JSON text +(such as commas). + +In Perl 5.005, C attribute is not available. +You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + +=item $json->incr_skip + +This will reset the state of the incremental parser and will remove the +parsed text from the input buffer. This is useful after C +died, in which case the input buffer and incremental parser state is left +unchanged, to skip the text parsed so far and to reset the parse state. + +=back + + + +=head1 GT::JSON::PP OWN METHODS + +=head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + +If C<$enable> is true (or missing), then C will accept +JSON strings quoted by single quotations that are invalid JSON +format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + +As same as the C option, this option may be used to parse +application-specific files written by humans. + + +=head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + +If C<$enable> is true (or missing), then C will accept +bare keys of JSON object that are invalid JSON format. + +As same as the C option, this option may be used to parse +application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + +=head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + +If C<$enable> is true (or missing), then C will convert +the big integer Perl cannot handle as integer into a L +object and convert a floating number (any) into a L. + +On the contary, C converts C objects and C +objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + +See to L aboout the normal conversion of JSON number. + +=head2 loose + + $json = $json->loose([$enable]) + +The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings +and the module doesn't allow to C to these (except for \x2f). +If C<$enable> is true (or missing), then C will accept these +unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + +See L. + +=head2 escape_slash + + $json = $json->escape_slash([$enable]) + +According to JSON Grammar, I (U+002F) is escaped. But default +GT::JSON::PP (as same as JSON::XS) encodes strings without escaping slash. + +If C<$enable> is true (or missing), then C will escape slashes. + +=head2 (OBSOLETED)as_nonblessed + + $json = $json->as_nonblessed + +(OBSOLETED) If C<$enable> is true (or missing), then C will convert +a blessed hash reference or a blessed array reference (contains +other blessed references) into JSON members and arrays. + +This feature is effective only when C is enable. + +=head2 indent_length + + $json = $json->indent_length($length) + +JSON::XS indent space length is 3 and cannot be changed. +GT::JSON::PP set the indent space length with the given $length. +The default is 3. The acceptable range is 0 to 15. + +=head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + +If $function_name or $subroutine_ref are set, its sort routine are used +in encoding JSON objects. + + $js = $pc->sort_by(sub { $GT::JSON::PP::a cmp $GT::JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub GT::JSON::PP::own_sort { $GT::JSON::PP::a cmp $GT::JSON::PP::b } + +As the sorting routine runs in the GT::JSON::PP scope, the given +subroutine name and the special variables C<$a>, C<$b> will begin +'GT::JSON::PP::'. + +If $integer is set, then the effect is same as C on. + +=head1 INTERNAL + +For developers. + +=over + +=item PP_encode_box + +Returns + + { + depth => $depth, + indent_count => $indent_count, + } + + +=item PP_decode_box + +Returns + + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + +=back + +=head1 MAPPING + +See to L. + + +=head1 UNICODE HANDLING ON PERLS + +If you do not know about Unicode on Perl well, +please check L. + +=head2 Perl 5.8 and later + +Perl can handle Unicode and the GT::JSON::PP de/encode methods also work properly. + + $json->allow_nonref->encode(chr hex 3042); + $json->allow_nonref->encode(chr hex 12345); + +Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. + + $json->allow_nonref->decode('"\u3042"'); + $json->allow_nonref->decode('"\ud808\udf45"'); + +Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. + +Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, +so GT::JSON::PP wraps the C with a subroutine. Thus GT::JSON::PP works slow in the versions. + + +=head2 Perl 5.6 + +Perl can handle Unicode and the GT::JSON::PP de/encode methods also work. + +=head2 Perl 5.005 + +Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. +That means the unicode handling is not available. + +In encoding, + + $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. + $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. + +Returns C and C, as C takes a value more than 255, it treats +as C<$value % 256>, so the above codes are equivalent to : + + $json->allow_nonref->encode(chr 66); + $json->allow_nonref->encode(chr 69); + +In decoding, + + $json->decode('"\u00e3\u0081\u0082"'); + +The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded +japanese character (C). +And if it is represented in Unicode code point, C. + +Next, + + $json->decode('"\u3042"'); + +We ordinary expect the returned value is a Unicode character C. +But here is 5.005 world. This is C<0xE3 0x81 0x82>. + + $json->decode('"\ud808\udf45"'); + +This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. + + +=head1 TODO + +=over + +=item speed + +=item memory saving + +=back + + +=head1 SEE ALSO + +Most of the document are copied and modified from JSON::XS doc. + +L + +RFC4627 (L) + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP/Boolean.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP/Boolean.pm new file mode 100644 index 0000000..2cd7c01 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP/Boolean.pm @@ -0,0 +1,26 @@ +=head1 NAME + +GT::JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + +=head1 SYNOPSIS + + # do not "use" yourself + +=head1 DESCRIPTION + +This module exists only to provide overload resolution for Storable and similar modules. See +L for more info about this class. + +=cut + +use GT::JSON::PP (); +use strict; + +1; + +=head1 AUTHOR + +This idea is from L written by Marc Lehmann + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP5005.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP5005.pm new file mode 100644 index 0000000..59a8911 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP5005.pm @@ -0,0 +1,148 @@ +package GT::JSON::PP5005; + +use 5.005; +use strict; + +my @properties; + +$GT::JSON::PP5005::VERSION = '1.08'; + +BEGIN { + + sub utf8::is_utf8 { + 0; # It is considered that UTF8 flag off for Perl 5.005. + } + + sub utf8::upgrade { + } + + sub utf8::downgrade { + 1; # must always return true. + } + + sub utf8::encode { + } + + sub utf8::decode { + } + + *GT::JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *GT::JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *GT::JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *GT::JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + + # missing in B module. + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + sub B::SVf_POK () { 0x00040000; } + sub B::SVp_IOK () { 0x01000000; } + sub B::SVp_NOK () { 0x02000000; } + + $INC{'bytes.pm'} = 1; # dummy +} + + + +sub _encode_ascii { + join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) ); +} + + +sub _encode_latin1 { + join('', map { chr($_) } unpack('C*', $_[0]) ); +} + + +sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode + my $bit = unpack('B32', pack('N', $uni)); + + if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) { + my ($w, $x, $y, $z) = ($1, $2, $3, $4); + return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z)); + } + else { + Carp::croak("Invalid surrogate pair"); + } +} + + +sub _decode_unicode { + my ($u) = @_; + my ($utf8bit); + + if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff + return pack( 'H2', $1 ); + } + + my $bit = unpack("B*", pack("H*", $u)); + + if ( $bit =~ /^00000(.....)(......)$/ ) { + $utf8bit = sprintf('110%s10%s', $1, $2); + } + elsif ( $bit =~ /^(....)(......)(......)$/ ) { + $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3); + } + else { + Carp::croak("Invalid escaped unicode"); + } + + return pack('B*', $utf8bit); +} + + +sub GT::JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub GT::JSON::PP::incr_text { + $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + + $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 ); + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub GT::JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip; +} + + +sub GT::JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +GT::JSON::PP5005 - Helper module in using GT::JSON::PP in Perl 5.005 + +=head1 DESCRIPTION + +GT::JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP56.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP56.pm new file mode 100644 index 0000000..2c19f0f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP56.pm @@ -0,0 +1,198 @@ +package GT::JSON::PP56; + +use 5.006; +use strict; + +my @properties; + +$GT::JSON::PP56::VERSION = '1.07'; + +BEGIN { + + sub utf8::is_utf8 { + my $len = length $_[0]; # char length + { + use bytes; # byte length; + return $len != length $_[0]; # if !=, UTF8-flagged on. + } + } + + + sub utf8::upgrade { + ; # noop; + } + + + sub utf8::downgrade ($;$) { + return 1 unless ( utf8::is_utf8( $_[0] ) ); + + if ( _is_valid_utf8( $_[0] ) ) { + my $downgrade; + for my $c ( unpack( "U*", $_[0] ) ) { + if ( $c < 256 ) { + $downgrade .= pack("C", $c); + } + else { + $downgrade .= pack("U", $c); + } + } + $_[0] = $downgrade; + return 1; + } + else { + Carp::croak("Wide character in subroutine entry") unless ( $_[1] ); + 0; + } + } + + + sub utf8::encode ($) { # UTF8 flag off + if ( utf8::is_utf8( $_[0] ) ) { + $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); + } + else { + $_[0] = pack( "U*", unpack( "C*", $_[0] ) ); + $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); + } + } + + + sub utf8::decode ($) { # UTF8 flag on + if ( _is_valid_utf8( $_[0] ) ) { + utf8::downgrade( $_[0] ); + $_[0] = pack( "U*", unpack( "U*", $_[0] ) ); + } + } + + + *GT::JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *GT::JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *GT::JSON::PP::JSON_PP_decode_surrogates = \>::JSON::PP::_decode_surrogates; + *GT::JSON::PP::JSON_PP_decode_unicode = \>::JSON::PP::_decode_unicode; + + unless ( defined &B::SVp_NOK ) { # missing in B module. + eval q{ sub B::SVp_NOK () { 0x02000000; } }; + } + +} + + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', GT::JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', GT::JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); +} + + +sub _unpack_emu { # for Perl 5.6 unpack warnings + return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) + : _is_valid_utf8($_[0]) ? unpack('U*', $_[0]) + : unpack('C*', $_[0]); +} + + +sub _is_valid_utf8 { + my $str = $_[0]; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + if ($is_utf8) { # eventually, not utf8 + return; + } + } + } + + return $is_utf8; +} + + +sub GT::JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub GT::JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub GT::JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip; +} + + +sub GT::JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +GT::JSON::PP56 - Helper module in using GT::JSON::PP in Perl 5.6 + +=head1 DESCRIPTION + +GT::JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP58.pm b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP58.pm new file mode 100644 index 0000000..d452380 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP58.pm @@ -0,0 +1,93 @@ +package GT::JSON::PP58; + +use 5.008; +use strict; + +my @properties; + +$GT::JSON::PP58::VERSION = '1.02'; + + +BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + *GT::JSON::PP::JSON_PP_encode_ascii = \>::JSON::PP::_encode_ascii; + *GT::JSON::PP::JSON_PP_encode_latin1 = \>::JSON::PP::_encode_latin1; + *GT::JSON::PP::JSON_PP_decode_surrogates = \>::JSON::PP::_decode_surrogates; + *GT::JSON::PP::JSON_PP_decode_unicode = \>::JSON::PP::_decode_unicode; + + if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package GT::JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + +} + + +sub GT::JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub GT::JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub GT::JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip; +} + + +sub GT::JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +GT::JSON::PP58 - Helper module in using GT::JSON::PP in Perl 5.8 and lator + +=head1 DESCRIPTION + +GT::JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm new file mode 100644 index 0000000..56b610b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm @@ -0,0 +1,178 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Lock +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $ +# +# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: a small autonomous locking module. +# +package GT::Lock; + +use vars qw/@EXPORT_OK $error $SAFETY $ERRORS/; +use strict; +use bases + 'Exporter' => '', + 'GT::Base' => ''; + +use constants + MASK => 0777, + SLEEPTIME => 0.05, + TIMEOUT => 10, + LOCK_TRY => 1, + LOCK_FORCE => 2; + +use POSIX qw/errno_h/; +use GT::TempFile; + +$ERRORS = { + 'TIMEOUT' => 'Could not lock %s; We timed out', + 'NOLOCK' => 'No lock was found for name %s' +}; +@EXPORT_OK = qw/lock unlock LOCK_FORCE LOCK_TRY/; + +sub lock { +#--------------------------------------------------------------------------------- + defined( $_[0] ) or GT::Lock->fatal( BADARGS => 'First argument must be a defined value' ); + my $name = escape($_[0]); + my $timeout = defined $_[1] ? $_[1] : TIMEOUT; + my $opt = defined $_[2] ? $_[2] : LOCK_FORCE; + my $max_age = $_[3]; + my $tmp_dir = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir(); + my $lock_dir = "$tmp_dir/$name"; + if ($max_age and -d $lock_dir and time - (stat $lock_dir)[9] > $max_age) { + rmdir $lock_dir or $! == ENOENT or GT::Lock->fatal(RMDIR => $lock_dir, "$!"); + } + my $start_time = time; + until (mkdir $lock_dir, MASK) { + select undef, undef, undef, SLEEPTIME; + if ($timeout and $start_time + $timeout < time) { + if ($opt == LOCK_TRY) { + return GT::Lock->warn(TIMEOUT => unescape($name)); + } + else { + # XXX - 2 appears to be No such file or directory, but may not be entirely portable. + unless (rmdir $lock_dir and $! != ENOENT) { + # The rmdir failed which *may* be due to two processes + # holding the same lock then the other one deleting it + # just before this one attempted to. In such a case, we + # allow double the timeout to try to avoid the race - + # though this reduces the frequency of race conditions, it + # does not completely eliminate it. + if ($timeout and $start_time + 2 * $timeout < time) { + GT::Lock->fatal(RMDIR => $lock_dir, "$!"); + } + } + } + } + } + return 1; +} + +sub unlock { +#-------------------------------------------------------------------------------- + my $name = escape($_[0]); + my $tmp_dir = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir(); + my $lock_dir = "$tmp_dir/$name"; + if (-d $lock_dir) { + rmdir $lock_dir or return GT::Lock->fatal(RMDIR => $lock_dir, "$!"); + } + else { + return GT::Lock->warn(NOLOCK => $name); + } + return 1; +} + +sub escape { +#-------------------------------------------------------------------------------- + my $toencode = $_[0]; + return unless (defined $toencode); + $toencode =~ s/([^\w. -])/sprintf "%%%02X", ord $1/eg; + $toencode =~ s/ /%20/g; + return $toencode; +} + +sub unescape { +#-------------------------------------------------------------------------------- + my $todecode = $_[0]; + return unless (defined $todecode); + $todecode =~ tr/+/ /; # pluses become spaces + $todecode =~ s/%([0-9a-fA-F]{2})/chr hex $1/ge; + return $todecode; +} + +1; + +__END__ + +=head1 NAME + +GT::Lock - a small autonomous locking module. + +=head2 SYNOPSIS + + use GT::Lock qw/lock unlock LOCK_TRY LOCK_FORCE/; + + # attempt to lock foobar for 10 seconds + if (lock 'foobar', 10, LOCK_TRY) { + # do some code that needs to be locked + unlock 'foobar'; + } + else { + # oops out lock failed + die "Lock failed: $GT::Lock::error\n"; + } + +=head1 DESCRIPTION + +GT::Lock is a very simple module to impliment autonomous named locking. Locking +can be used for many things but is most commonly used to lock files for IO to +them. + +Nothing is exported by default. You may request the lock, unlock routines be +exported. You can also get the two constants for lock types exported: +C and C. + +=head2 lock - Lock a name. + + lock NAME [, TIMOUT, TYPE, AGE ] + +This method is used to create a lock. Its arguments are the name you wish to +give the lock, the timeout in seconds for the lock to happen, the type of lock, +and the maximum lock age (in seconds). The types are C and +C. If C is given a lock always succeeds, e.g. if the +lock times out the lock is removed and your lock succeeds. Try attempts to get +the lock and returns false if the lock can not be had in the specified +C. If C is zero this method will attempt to lock forever. +C defaults to 10 seconds. The AGE parameter can be used to ensure +that stale locks are not preserved - if the lock already exists and is older +than AGE seconds, it will be removed before attempting to get the lock. +Omitting it uses the default value, undef, which does not attempt to remove +stale locks. + +=head2 unlock - unlock a name. + + unlock NAME + +This method is used to unlock a name. It's argument is the name of the lock to +unlock. Returns true on success and false on errors and sets the error in +$GT::Lock::error. + +=head1 DEPENDANCIES + +L depends on L, L, and L. + +=head1 COPYRIGHT + +Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/MD5.pm b/site/slowtwitch.com/cgi-bin/articles/GT/MD5.pm new file mode 100644 index 0000000..6a6e12b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/MD5.pm @@ -0,0 +1,520 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::MD5 +# Author: Scott Beck (see pod for details) +# CVS Info : 087,071,086,086,085 +# $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() { + 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 an interface (like C) 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 instead of this module if it is available. +This module is only usefull for + +=over 4 + +=item + +computers where you cannot install C (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. 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 module is available it is used and if not you take +C. + +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 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 for those amounts of data anyway. + +=back + +=head1 SEE ALSO + +L + +L + +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 +(). + +C was made by Gisle Aas (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 . + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/MD5/Crypt.pm b/site/slowtwitch.com/cgi-bin/articles/GT/MD5/Crypt.pm new file mode 100644 index 0000000..b3b76cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/MD5/Crypt.pm @@ -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): +# 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 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): + 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 provides a function compatible with Apache's +C<.htpasswd> files. This was contributed by Bryan Hart . +As suggested by William A. Rowe, Jr. , it is +exported by default. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/MIMETypes.pm b/site/slowtwitch.com/cgi-bin/articles/GT/MIMETypes.pm new file mode 100644 index 0000000..d508b1a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/MIMETypes.pm @@ -0,0 +1,457 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::MIMETypes +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: MIMETypes.pm,v 1.30 2012/01/26 00:36:19 brewt 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) { + %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}; + } + %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 =~ /\.([^.]+)$/) { + %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}; + } + %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 + %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', + diff => 'txt.gif', + patch => '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', + ogg => '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', + ogv => 'video.gif', + mp4 => 'video.gif', + webm => 'video.gif', + wmv => 'wvideo.gif', + wma => 'wvideo.gif', + sh => 'shellscript.gif', + rpm => 'rpm.gif', + ttf => 'font_true.gif', + doc => 'doc.gif', + docx => 'doc.gif', + xls => 'excel.gif', + xlsx => 'excel.gif', + ppt => 'ppt.gif', + pptx => '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', + docx => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document', + ppt => 'application/vnd.ms-powerpoint', + pptx => 'application/vnd.openxmlformats-officedocument.presentationml.presentation', + xls => 'application/vnd.ms-excel', + xlsx => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet', + 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', + ogg => 'application/ogg', + 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', + diff => 'text/plain', + patch => 'text/plain', + tsv => 'text/tab-separated-values', + etx => 'text/x-setext', + ogv => 'video/ogg', + mp4 => 'video/mp4', + webm => 'video/webm', + 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 => 'audio/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/powerpoint' => 'ppt.gif', + 'application/mspowerpoint' => 'ppt.gif', + 'application/vnd.ms-powerpoint' => 'ppt.gif', + 'application/x-mspowerpoint' => 'ppt.gif', + 'application/vnd.openxmlformats-officedocument.presentationml.presentation' => 'ppt.gif', + 'application/msword' => 'doc.gif', + 'application/vnd.openxmlformats-officedocument.wordprocessingml.document' => 'doc.gif', + 'application/excel' => 'excel.gif', + 'application/msexcel' => 'excel.gif', + 'application/vnd.ms-excel' => 'excel.gif', + 'application/x-msexcel' => 'excel.gif', + 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet', => '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', + 'application/ogg' => '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/ogg' => 'video.gif', + 'video/mp4' => 'video.gif', + 'video/webm' => 'video.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', + 'audio/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 and C. +They take either a filename or a hash reference. + +C 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.30 2012/01/26 00:36:19 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Mail.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Mail.pm new file mode 100644 index 0000000..63f305f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Mail.pm @@ -0,0 +1,988 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Mail +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 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.77 $ =~ /(\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->{smtp_helo} = delete $opt->{smtp_helo} || ''; + $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 [, eol-sequence]); +# ----------------------------------- +# $obj->parse('/path/to/file' [, eol-sequence]); +# ---------------------------------------------- +# $obj->parse($SCALAR_REF -or- $SCALAR [, eol-sequence]); +# ------------------------------------------------------- +# Takes a path to a file, file handle, scalar or scalar reference containing +# the e-mail, and optionally a second argument specifying the EOL sequence to +# use when parsing (defaults to "\n" - corresponds directly to the +# GT::Mail::Parse crlf method). +# Returns head part 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, $eol) = @_; + +# Require our parser + require GT::Mail::Parse; + +# Get a new parser object + $self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug}); + $self->{parser}->crlf($eol) if $eol; + $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 [, eol-sequence]); +# ----------------------------------------- +# $obj->parse_head ('/path/to/file' [, eol-sequence]); +# ---------------------------------------------------- +# 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, $eol) = @_; + +# Require our parser + require GT::Mail::Parse; + +# Get a new parser object + $self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug}); + $self->{parser}->crlf($eol) if $eol; + $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}, + helo => $self->{smtp_helo}, + 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 continue + $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); + } + +# 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 defined 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; + select((select($io), $| = 1)[0]); + $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" , this will return +# ('Jason Rhinelander', 'jason@gossamer-threads.com'). It handes escapes as +# well - "Jason \(\"jagerman\"\) Rhinelander" +# 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 or $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 + if (my $c = $part->get('Content-Type')) { + unless ($c =~ /;\s*boundary="\Q$bound\E"/i) { + $self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug}; + $part->set('Content-Type' => qq{$c; 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 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 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. 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 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. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm new file mode 100644 index 0000000..4711b76 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm @@ -0,0 +1,1275 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Mail::BulkMail +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: BulkMail.pm,v 1.51 2008/01/23 07:27:00 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A simple bulk e-mail module to interface with either +# sendmail or SMTP. +# +# ================================================================== + +package GT::Mail::BulkMail; + +use Exporter; +use GT::Base; +use GT::Socket::Client; +use GT::Mail::Encoder; +use constants CRLF => "\015\012", CR => "\015", LF => "\012"; +use strict; +use GT::AutoLoader; +use vars qw(@ISA $VERSION $AUTOLOAD @EXPORT_OK %EXPORT_TAGS $VALID_HOST $CRLF $CR $LF $noIPCOpen2); + +eval "use IPC::Open2"; +$noIPCOpen2++ if $@; + +@ISA = qw(Exporter); + +@EXPORT_OK = qw(RFC822_date quoted_printable quote_name unquote_name + $VALID_HOST CR LF CRLF $CR $LF $CRLF); + +%EXPORT_TAGS = ( + quoting => [ qw/quoted_printable quote_name unquote_name/ ], + crlf => [ qw/CR LF CRLF $CR $LF $CRLF/ ], +); + +$VERSION = sprintf "%d.%03d", q$Revision: 1.51 $ =~ /(\d+)\.(\d+)/; + +$VALID_HOST = '(?:[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)*)'; + +$CR = CR; +$LF = LF; +$CRLF = CRLF; + +sub DESTROY { + my $self = shift; + $self->_smtp_disconnect();# if $self->{smtp_connected}; + $self->_sendmail_disconnect();# if $self->{sendmail_connected}; +} + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { }; + bless $self, $class; + $self->_init(@_); + return $self; +} + +# Parses all passed options to new, such as -from, -name, -smtp, etc. +sub _init { + my $self = shift; + my %options = @_; +# These two should be first so that errors can be handled that the others might cause + $self->show_errors(delete $options{-show_errors}) if exists $options{-show_errors}; + $self->error_code(delete $options{-error_code}) if exists $options{-error_code}; + $self->from(delete $options{-from}) if exists $options{-from}; + $self->name(delete $options{-name}) if exists $options{-name}; + $self->subject(delete $options{-subject}) if exists $options{-subject}; + $self->message(delete $options{-message}) if exists $options{-message}; + $self->success(delete $options{-success}) if exists $options{-success}; + $self->failure(delete $options{-failure}) if exists $options{-failure}; + $self->messagepresend(delete $options{-messagepresend}) if exists $options{-messagepresend}; + $self->subjectpresend(delete $options{-subjectpresend}) if exists $options{-subjectpresend}; + $self->frompresend(delete $options{-frompresend}) if exists $options{-frompresend}; + $self->namepresend(delete $options{-namepresend}) if exists $options{-namepresend}; + $self->smtp_retries(0); + $self->smtp_retries(delete $options{-smtp_retries}) if exists $options{-smtp_retries}; + $self->smtp_wait(2.5); + $self->smtp_wait(delete $options{-smtp_wait}) if exists $options{-smtp_wait}; + $self->_method(\%options); # Figures out (sendmail or smtp) and (text or html) + if (keys %options) { + my $forgot_dash = 0; + for (keys %options) { + $self->_cause_error("Unknown parameter `$_'"); + $forgot_dash++ if substr($_, 0, 1) ne '-'; + } + die "Invalid parameters (" . join(", ", keys %options) . ") to new()" . ($forgot_dash ? " - perhaps you forgot the -dash?" : ""); + } +} + +# Tries to figure out whether to use sendmail, or SMTP to send the message by +# looking for the -smtp or -sendmail options. +# Also looks for -text or -html options +sub _method { + my ($self,$options) = splice @_,0,2; + + if ($options->{-sendmail} and $options->{-smtp}) { + $self->_cause_error("Invalid method: Two mailing methods provided. Choose only smtp or sendmail"); + delete $options->{-sendmail}; + delete $options->{-smtp}; + } + elsif ($options->{-sendmail}) { + $self->sendmail(delete $options->{-sendmail}); + delete $options->{-smtp}; + } + elsif ($options->{-smtp}) { + $self->smtp(delete $options->{-smtp}); + delete $options->{-sendmail}; + } + my $t = $options->{-text}; + my $h = $options->{-html}; + my $r = $options->{-raw}; + + if (($h and $r) or ($t and $r) or ($t and $h)) { + $self->_cause_error("Invalid mail format: Choose only one format to use."); + delete $options->{-text}; + delete $options->{-html}; + delete $options->{-raw}; + } + elsif ($options->{-text}) { + $self->text(1); + delete $options->{-text}; + delete $options->{-html}; + delete $options->{-raw}; + } + elsif ($options->{-html}) { + $self->html(1); + delete $options->{-html}; + delete $options->{-text}; + delete $options->{-raw}; + } + elsif ($options->{-raw}) { + $self->raw(1); + delete $options->{-html}; + delete $options->{-text}; + delete $options->{-raw}; + } +} + + +# This subroutine handles the creation of errors and prints them (if +# show_errors is set), and/or passes them to error_code (if set). +$COMPILE{_cause_error} = __LINE__ . <<'END_OF_SUB'; +sub _cause_error { + my $self = shift; + my $error = shift; + warn ref($self)." Error: $error" if $self->{show_errors}; + $self->{error_code}->($error) if ref $self->{error_code} eq 'CODE'; +} +END_OF_SUB + +# All of the following methods (down to _check_params) will return the current +# value of that parameter if called without arguments. + +# Sets a code ref which will be called with an error message each time an +# error occurs. +$COMPILE{error_code} = __LINE__ . <<'END_OF_SUB'; +sub error_code { + my $self = shift; + if (@_) { + if (ref $_[0] eq 'CODE') { + $self->{error_code} = shift; + } + else { + $self->_cause_error("Not a code reference passed to error_code"); + } + } + else { + return $self->{error_code}; + } +} +END_OF_SUB + + +# Sets whether or not to print errors whenever an error occurs. +$COMPILE{show_errors} = __LINE__ . <<'END_OF_SUB'; +sub show_errors { + my $self = shift; + if (@_) { + $self->{show_errors} = shift; + return; + } + return $self->{show_errors}; +} +END_OF_SUB + +# Sets the e-mail address of the sender. Takes one arg: The e-mail address of +# the sender. +sub from ($;$) { + my $self = shift; + if (@_) { + if (_is_valid_email($_[0])) { + $self->{from} = shift; + return 1; + } + else { + $self->_cause_error("Invalid e-mail address: `$_[0]'"); + return; + } + } + else { + return $self->{from}; + } +} + +# Sets the presend code ref for the from field. +# Takes one argument: a code ref +$COMPILE{frompresend} = __LINE__ . <<'END_OF_SUB'; +sub frompresend { + my $self = shift; + if (@_) { + $self->{frompresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{frompresend}; + } +} +END_OF_SUB + +# Sets the body of the message. +# Takes one argument: a string. +sub message ($;$) { + my $self = shift; + if (@_) { + $self->{message} = shift; + return; + } + return $self->{message}; +} + +# Sets a presend code ref for the body of the message. +# Takes a code ref as argument +$COMPILE{messagepresend} = __LINE__ . <<'END_OF_SUB'; +sub messagepresend { + my $self = shift; + if (@_) { + $self->{messagepresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{messagepresend}; + } +} +END_OF_SUB + +# Sets the display name of the sender. Will be escaped and quoted. +# Without args, returns the name (not quoted, of course). +sub name ($;$) { + my $self = shift; + if (@_) { + if (_is_valid_name($_[0])) { + $self->{name} = quote_name(shift); + return 1; + } + else { + $self->_cause_error("Invalid name"); + return; + } + } + else { + return unquote_name($self->{name}); + } +} + +# name presend - takes a code ref +$COMPILE{namepresend} = __LINE__ . <<'END_OF_SUB'; +sub namepresend { + my $self = shift; + if (@_) { + $self->{namepresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return $self->{namepresend}; + } +} +END_OF_SUB + +# Sets the subject of the message +sub subject ($;$) { + my $self = shift; + if (@_) { + $self->{subject} = shift; + return; + } + else { + return $self->{subject}; + } +} + +# Sets the subject presend for the e-mail +$COMPILE{subjectpresend} = __LINE__ . <<'END_OF_SUB'; +sub subjectpresend { + my $self = shift; + if (@_) { + $self->{subjectpresend} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{success} eq 'CODE' + ? $self->{success} + :($self->{success} = undef); + } +} +END_OF_SUB + +# Sets the number of times to attempt connection to the SMTP server before +# giving up. +sub smtp_retries ($;$) { + my $self = shift; + if (@_) { + my $retries = shift; + if (!$retries or $retries =~ /\D/) { + $self->{smtp_retries} = 0; + } + else { + $self->{smtp_retries} = $retries; + } + return; + } + return $self->{smtp_retries}; +} + +# Sets the wait time between SMTP connection reattempts. +sub smtp_wait ($;$) { + my $self = shift; + if (@_) { + my $wait = shift; + unless ($wait and $wait =~ /^\d+(?:\.\d+)?$/) { + $self->{smtp_wait} = 0; + } + else { + $self->{smtp_wait} = $wait; + } + return; + } + return $self->{smtp_wait}; +} + +# Sets that the format of the message should be plain text. +# Note that this does NOT set the text of the message! +$COMPILE{text} = __LINE__ . <<'END_OF_SUB'; +sub text { + my $self = shift; + if (@_) { + $self->{format} = "text/plain" if $_[0]; + return; + } + $self->{format} eq "text/plain"; +} +END_OF_SUB + +# Sets that the format of the message should be HTML +$COMPILE{html} = __LINE__ . <<'END_OF_SUB'; +sub html { + my $self = shift; + if (@_) { + if ($_[0]) { + $self->{format} = "text/html"; + } + else { + $self->{format} = "text/plain"; + } + return; + } + $self->{format} eq "text/html"; +} +END_OF_SUB + +$COMPILE{raw} = __LINE__ . <<'END_OF_SUB'; +sub raw { + my $self = shift; + if (@_) { + $self->{raw} = shift; + return; + } + $self->{raw}; +} +END_OF_SUB + +# Sets a code reference to be called when a message has (as far as the mailer +# can tell) been sent successfully. +$COMPILE{success} = __LINE__ . <<'END_OF_SUB'; +sub success { + my $self = shift; + if (@_) { + $self->{success} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{success} eq 'CODE' + ? $self->{success} + :($self->{success} = undef); + } +} +END_OF_SUB + +# Sets a code reference to call when sending a message as failed. +$COMPILE{failure} = __LINE__ . <<'END_OF_SUB'; +sub failure { + my $self = shift; + if (@_) { + $self->{failure} = shift if ref $_[0] eq 'CODE'; + return; + } + else { + return ref $self->{failure} eq 'CODE' + ? $self->{failure} + : ($self->{failure} = undef); + } +} +END_OF_SUB + +# Returns a list of custom headers that have been set +$COMPILE{headers} = __LINE__ . <<'END_OF_SUB'; +sub headers { + my $self = shift; + wantarray ? %{$self->{header}} : $self->{header}; +} +END_OF_SUB + +# Adds a single custom header. The header must start with X- +$COMPILE{add_header} = __LINE__ . <<'END_OF_SUB'; +sub add_header { + my $self = shift; + $self->_cause_error("Wrong number of arguments to add_header()") and return unless @_ == 2; + my ($k,$v) = splice @_,0,2; + $k =~ y/\x00-\x1f://d; + $v =~ s/\r?\n/$CRLF/g; + $v =~ s/(?:$CRLF){2,}/$CRLF/g; + $v =~ s/$CRLF$//; + if (($self->raw) || (substr($k,0,2) eq 'X-')) { + $self->{header}{$k} = $v; + } + else { + $self->_cause_error("Only X-* headers can be added"); + } +} +END_OF_SUB + +# Adds multiple headers. This makes calls to add_header() +$COMPILE{add_headers} = __LINE__ . <<'END_OF_SUB'; +sub add_headers { + my $self = shift; + $self->_cause_error("Wrong number of arguments to add_headers()") and return if @_ % 2; + while (@_) { + $self->add_header(splice @_,0,2); + } +} +END_OF_SUB + +# Deletes (and returns the value of) the header given. +$COMPILE{delete_header} = __LINE__ . <<'END_OF_SUB'; +sub delete_header { + my $self = shift; + my $key = shift; + delete $self->{header}{$key}; +} +END_OF_SUB + +# Deletes (and returns the values of) the headers given. +$COMPILE{delete_headers} = __LINE__ . <<'END_OF_SUB'; +sub delete_headers { + my $self = shift; + delete @{$self->{header}}{@_}; +} +END_OF_SUB + +# Sets the sending method to SMTP and sets the smtp server to the argument +# given. +$COMPILE{smtp} = __LINE__ . <<'END_OF_SUB'; +sub smtp { + my $self = shift; + if (@_) { + my $smtp = shift; + chomp $smtp; + if ($smtp =~ /^$VALID_HOST\Z/) { + $self->{method} = "smtp"; + delete $self->{sendmail}; + $self->{smtp} = $smtp; + $self->{smtp_attempts} = 0; + $self->{smtp_connected} = 0; + delete $self->{handle_in}; + delete $self->{handle_out}; + delete $self->{smtp_supported}; + return 1; + } + else { + $self->_cause_error("Bad SMTP server name provided ($smtp)"); + return; + } + } + else { + return $self->{smtp}; + } +} +END_OF_SUB + +# Sets the sending method to sendmail and sets the sendmail path to the +# argument given. +$COMPILE{sendmail} = __LINE__ . <<'END_OF_SUB'; +sub sendmail { + my $self = shift; + if (@_) { + my $sendmail = shift; + my ($executable, $tags) = split ' ', $sendmail, 2; + if (-x $executable) { + $self->{method} = "sendmail"; + if ($tags) { + $self->{sendmail_with_tags} = $self->{sendmail} = $sendmail; + # Using tags assumes that a method equivelant to -t is being used + $self->{no_sendmail_bs} = 1; + } + else { + $self->{sendmail} = $sendmail; + delete $self->{no_sendmail_bs}; + } + return 1; + } + else { + $self->_cause_error("Cannot execute $sendmail"); + return 0; + } + } + else { + return $self->{sendmail_with_tags} || $self->{sendmail}; + } +} +END_OF_SUB + +# checks that there is enough information set to send the e-mail +sub _check_params { + my $self = shift; + my $errors = ""; + unless ($self->{from}) { + $errors .= "`from' address not set. "; + } + elsif (not _is_valid_email($self->{from})) { + $errors .= "`$self->{from}' is not a valid e-mail address. "; + } + if ($self->{name} and not _is_valid_name($self->{name})) { + $errors .= "`$self->{name}' is not a valid name. "; + } + unless ($self->{$self->{method}}) { + $errors .= "No mail sending method set! "; + } + $errors and $self->_cause_error($errors . "Send aborted."), return; + return 1; +} + +# Checks whether or not the provided e-mail address is valid. +$COMPILE{_is_valid_email} = __LINE__ . <<'END_OF_SUB'; +sub _is_valid_email { + shift if ref $_[0]; + my $email = shift; + return $email && $email =~ /^[\x21-\x7e]+\@$VALID_HOST$/; +} +END_OF_SUB + +# Checks that a name is valid. +$COMPILE{_is_valid_name} = __LINE__ . <<'END_OF_SUB'; +sub _is_valid_name { + shift if ref $_[0]; + my $name = shift; + return not $name =~ y/\x20-\x7e//c; # 7-bit only with no control characters +} +END_OF_SUB + +# Sends an e-mail. Takes multiple arguments: Any number of: +# - array references +# - code references +# - hash references +# - glob references +# See the perldoc of this file for more info +sub send { + my $self = shift; + unless ($self->_check_params) { + $self->_cause_error("Not all neccessary parameters provided. No emails sent."); + return; + } + else { + $self->{date} = RFC822_date(); # Just get it once rather than figuring it out each time. + if ($self->{method} eq 'smtp') { + $self->_smtp_connect(); + } + elsif ($self->{method} eq 'sendmail') { + $self->_sendmail_connect(); + } + for (@_) { + ref eq 'GLOB' and $self->_send_globref($_), next; + ref eq 'HASH' and $self->_send_hashref($_), next; + ref eq 'ARRAY' and $self->_send_arrayref($_), next; + ref eq 'CODE' and $self->_send_coderef($_), next; + $self->_cause_error("Invalid argument to ".ref($self)."->send()"); + } + } +} + +$COMPILE{_send_arrayref} = __LINE__ . <<'END_OF_SUB'; +sub _send_arrayref { + my $self = shift; + my $array = shift; + for (@$array) { + $self->_send_one($_); + } +} +END_OF_SUB + +$COMPILE{_send_coderef} = __LINE__ . <<'END_OF_SUB'; +sub _send_coderef { + my $self = shift; + my $code = shift; + my ($id,$email); + $id = "temp"; + while ($id) { + ($id, $email) = $code->() or last; + $self->_send_one($email ? ($id,$email) : $id); + } +} +END_OF_SUB + +$COMPILE{_send_globref} = __LINE__ . <<'END_OF_SUB'; +sub _send_globref { + my $self = shift; + my $file = shift; + unless (defined fileno $file) { + $self->_cause_error("Glob reference passed to send is not an opened file"); + return; + } + my $addr; + while ($addr = <$file>) { + $addr =~ s/\r?\n$//; # Allow for windows line ends on *nix systems + $self->_send_one($addr); + } +} +END_OF_SUB + +$COMPILE{_send_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _send_hashref { + my $self = shift; + my $hash = shift; + my ($id,$email); + $self->_send_one($id,$email) while ($id,$email) = each %$hash; +} +END_OF_SUB + +# Sends a single e-mail message. Should not be called except by one of the 4 +# subroutines above. +sub _send_one { + my $self = shift; + my ($id,$email) = @_ > 1 ? (splice @_,0,2) : ((shift) x 2); + substr($email,rindex($email,'@')) =~ y/A-Z/a-z/; + my $success; + my $from = ref $self->{frompresend} eq 'CODE' + ? ($self->{frompresend}->($id,$self->{from}) || $self->{from}) + : $self->{from}; + $from =~ y/\x21-\x7e//cd; + my $name = ref $self->{namepresend} eq 'CODE' + ? quote_name($self->{namepresend}->($id,unquote_name($self->{name}))) || $self->{name} + : $self->{name}; + $name =~ y/\x20-\x7e//cd; + my $subject; + $subject = ref $self->{subjectpresend} eq 'CODE' + ? ($self->{subjectpresend}->($id,$self->{subject}) || $self->{subject}) + : $self->{subject}; + $subject =~ y/\x20-\x7e//cd; + my $message = ref $self->{messagepresend} eq 'CODE' + ? ($self->{messagepresend}->($id,$self->{message}) || $self->{message}) + : $self->{message}; + if ($self->{method}) { + if ($noIPCOpen2 || $self->{no_sendmail_bs} and $self->{method} eq 'sendmail') { + $success = $self->_sendmail_t_send($email,$from,$name,$subject,$message); + } + else { + $success = $self->_smtp_send($email,$from,$name,$subject,$message); + } + } + else { + $self->_cause_error("No mail sending method set!"); + return; + } + if ($success and ref $self->{success} eq 'CODE') { + $self->{success}->($id); + } + elsif (!$success and ref $self->{failure} eq 'CODE') { + $self->{failure}->($id); + } +} + +# Creates a connection to the STMP server +$COMPILE{_smtp_connect} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_connect { + my $self = shift; + $self->_smtp_disconnect if $self->{smtp_connected}; + $self->{method} eq 'sendmail' and return $self->_sendmail_connect; + local $/ = CRLF; + local $\ = CRLF; + + my $s; + $self->{smtp_connected} = 0; + + while (not $self->{smtp_connected} and $self->{smtp_attempts}++ <= $self->{smtp_retries}) { + select(undef,undef,undef,$self->{smtp_wait}) if $self->{smtp_attempts} > 1 + and $self->{smtp_wait} and $self->{smtp_wait} > 0; + + $s = GT::Socket::Client->open( + host => $self->{smtp}, + port => 25, + timeout => 10 + ) or $self->_cause_error("$self->{smtp}: Unable to connect: " . GT::Socket::Client->error); + + $self->{handle_out} = $self->{handle_in} = $s; + $_ = <$s>; + unless (/^220/) { + $self->_cause_error("$self->{smtp}: Server not available: $_"); + close $s; + next; + } + while (/^220-/) { + $_ = <$s>; + } + if (my $error = $self->_smtp_say_hi) { + $self->_cause_error("$self->{smtp}: $error"); + close $s; + next; + } + $self->{smtp_connected} = 1; + } + return $self->{smtp_connected}; +} +END_OF_SUB + +# Disconnects from the SMTP server +sub _smtp_disconnect { + my $self = shift; + return $self->_sendmail_disconnect if $self->{method} eq 'sendmail'; + local $/ = CRLF; + local $\ = CRLF; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + if (defined $out) { + print $out "QUIT"; + } + close $out; + close $in; + delete $self->{handle_out}; + delete $self->{handle_in}; + 1; +} + +# Does all the initialization required before sending a message +$COMPILE{_smtp_say_hi} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_say_hi { + my $self = shift; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + local $/ = CRLF; + local $\ = CRLF; + print $out "EHLO localhost"; + local $_ = <$in>; + return "No server response" unless defined; + if (/^5\d\d\s+(.*)/) { # Not ESMTP + delete $self->{smtp_esmtp}; + print $out "HELO localhost"; + $_ = <$in>; + return "No server response to HELO command (EHLO failed)" unless defined; + } + else { + $self->{smtp_esmtp}++; + } + s/$CRLF/\n/; + return "Invalid server response: $_" if !/^\d{3}/; + return "Server error: $_" if /^[45]/; + return if /^250 /; # Just a plain SMTP greeting + while (defined($_=<$in>) and /^250-/) { # 250- is a possible greeting, indicating more lines coming. + s/$CRLF/\n/; + /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1"; + } + !defined || /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1"; + return; +} +END_OF_SUB + +# Actually sends the message using SMTP protocols. +$COMPILE{_smtp_send} = __LINE__ . <<'END_OF_SUB'; +sub _smtp_send { + my ($self,$to,$from,$name,$subject,$message) = @_; + return unless _is_valid_email($to); + local $/ = CRLF; + local $\ = CRLF; + local $_; + + unless ($self->{smtp_connected}) { + $self->_smtp_connect(); + } + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + print $out "RSET"; + $_ = <$in>; + s/$CRLF$//; + if (not defined or /^(?:221|[45]\d\d)\s*(.*)/) { + $self->_cause_error("Cannot reset connection: ".($1 || "No response from server").". Reconnecting"); + $self->{smtp_attempts} = 0; # It could be that the server will only take one connection, although + # this defeats any advantage this module has over any module designed to send just one message. + unless ($self->_smtp_connect()) { + $self->_cause_error("Fatal: Could not reestablish connection"); + die "Could not reestablish connection"; + } + } + if (/^221\s*(.*)/) { + $self->_smtp_disconnect(); + $self->_cause_error("Server disconnected: $1"); + return; + } + + my $return = $self->{header}->{'Return-Path'} || $from; + print $out "MAIL FROM: <$return>"; + + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect(); + $self->_cause_error("Server disconnected: $1"); + return; + } + unless (/^250/) { + # The error message won't be helpful here (it will be a syntax error). + # The only way an error can occur here is for an invalid email address. + $self->_cause_error("From address (`$from') rejected by server ($_)"); + # If the from was rejected once, it will be rejected again. + die "From address (`$from') rejected by server."; + } + print $out "RCPT TO: <$to>"; + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect; + $self->_cause_error("Server disconnected: $1. Attempting to reconnect..."); + $self->{smtp_attempts} = 0; + unless ($self->_smtp_connect()) { + $self->_cause_error("Fatal error: Could not reestablish connection"); + die "Could not reestablish connection"; + } + return &_smtp_send; # redo this mail + } + unless (/^25[01]/) { + /^\d{3}\s*(.*)/; + $self->_cause_error("Recipient ($to) refused by server: $1"); + return; + } + print $out "DATA"; + $_ = <$in>; + s/$CRLF$//; + if (/^221\s*(.*)/) { + $self->_smtp_disconnect; + $self->_cause_error("Server disconnected: $1. Attempting to reconnect..."); + $self->{smtp_attempts} = 0; + unless ($self->_smtp_connect) { + $self->_cause_error("Fatal error: Could not reestablish connection"); + die "Could not reestablish connection"; + } + return &_smtp_send; # redo this mail + } + unless (/^354/) { + $self->_cause_error("Invalid server response to DATA ($_). Attempting to reset and resend."); + return &_smtp_send; + } + my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $]; + $from = "$name <$from>" if defined $name and $name =~ /\S/; + print $out "Return-Path: $return"; + print $out "Date: $self->{date}"; + print $out "From: $from"; + print $out "Subject: $subject"; + print $out "To: $to"; + print $out "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'}; + print $out "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'}; + print $out "Content-Type: $self->{format}" if $self->{format}; + 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 ($host) { + print $out 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>'; + } + while (my ($k,$v) = each(%{$self->{header}})) { + next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id'; + print $out "$k: $v"; + } + print $out ""; + $message =~ s/\015?\012/$CRLF/g if $self->{raw}; + $message = quoted_printable($message) unless $self->{raw}; + $message =~ s/^\./../gm; + print $out $message; + print $out "."; + $_ = <$in>; + return /^250/; +} +END_OF_SUB + +# Establishes a sendmail -bs (emulates SMTP) connection via IPC::Open2 +$COMPILE{_sendmail_connect} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_connect { + my $self = shift; + local $/ = CRLF; + local $\ = CRLF; + my $in = \do { local *INPUT; *INPUT; }; + my $out = \do { local *OUTPUT; *OUTPUT; }; + $self->_smtp_disconnect if $self->{sendmail_pid} or $self->{smtp_connected}; + my $pid = eval { open2($in,$out,"$self->{sendmail} -bs") }; + + $self->{handle_in} = $in; + $self->{handle_out} = $out; + if ($@) { + # Could not run sendmail at all + $self->_cause_error("Unable to open sendmail: $@"); + return; + } + $_ = <$in>; + s/\n$//; + unless (/^220/) { + # sendmail can be run, but apparently it doesn't like the -bs option + $self->_cause_error("$self->{sendmail}: SMTP compatible mode not available: $_. Using -t mode instead."); + close $in; + close $out; + waitpid $pid,0; + $self->{no_sendmail_bs}++; + return 1; + } + while (/^220-/) { + $_ = <$in>; + } + if (my $error = $self->_smtp_say_hi) { + $self->_cause_error("Sendmail (SMTP mode) error: $error"); + close $in; + close $out; + waitpid $pid,0; + return; + } + $self->{sendmail_pid} = $pid; + $self->{smtp_connected} = 1; + return 1; +} +END_OF_SUB + +# Disconnects from sendmail (in sendmail -bs mode) +$COMPILE{_sendmail_disconnect} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_disconnect { + my $self = shift; + my $in = $self->{handle_in}; + my $out = $self->{handle_out}; + my $pid = $self->{sendmail_pid}; + close $in if $in; + close $out if $out; + waitpid $pid, 0 if $pid; + delete $self->{handle_in}; + delete $self->{handle_out}; + delete $self->{sendmail_pid}; + delete $self->{smtp_connected}; + 1; +} +END_OF_SUB + +# Sends with sendmail -t mode. This should only be called when IPC::Open2 is +# not available or sendmail does not support the -bs switch. It is intended as +# a backup solution only. +$COMPILE{_sendmail_t_send} = __LINE__ . <<'END_OF_SUB'; +sub _sendmail_t_send { + my ($self,$to,$from,$name,$subject,$message) = splice @_,0,6; + local $/ = LF; + local $\ = LF; + return unless _is_valid_email($to); + local *SENDMAIL; + my $to_open = $self->{sendmail_with_tags} || "$self->{sendmail} -t -oi -odq"; + unless (open(SENDMAIL, "| $to_open")) + { + $self->_cause_error("Can't run sendmail ($to_open): $!"); + return; + } + my $return = $self->{header}->{'Return-Path'} || $from; + $from = "$name <$from>" if defined $name and $name =~ /\S/; + my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $]; + print SENDMAIL "Return-Path: $return"; + print SENDMAIL "Date: $self->{date}"; + print SENDMAIL "From: $from"; + print SENDMAIL "Subject: $subject"; + print SENDMAIL "To: $to"; + print SENDMAIL "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'}; + print SENDMAIL "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'}; + print SENDMAIL "Content-Type: $self->{format}" if $self->{format}; + my $host = $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : ''; + if ($host) { + print SENDMAIL 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>'; + } + while (my ($k,$v) = each %{$self->{header}}) { + next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id'; + print SENDMAIL "$k: $v"; + } + unless ($self->{raw}) { + $message = quoted_printable($message); +# quoted_printable returns a string with CRLF newlines + $message =~ s/$CRLF/$LF/gs; + } + $message =~ s/^\.$LF$/. $LF/gm; + print SENDMAIL $message; + close SENDMAIL; + !$?; +} +END_OF_SUB + +# Returns the argument passed with quotes around it and special characters +# escaped for use in the From: line of an e-mail. +sub quote_name { + shift if ref $_[0]; # In case you call $self->quote_name($string); + my $toquote = shift; + $toquote =~ s/(?=[(")\\])/\\/g; + substr($toquote,0,0) = '"'; + $toquote .= '"'; + $toquote; +} + +# unquotes (as per the above) the argument +$COMPILE{unquote_name} = __LINE__ . <<'END_OF_SUB'; +sub unquote_name { + shift if ref $_[0]; + my $tounquote = shift; + $tounquote =~ s/^"// and $tounquote =~ s/"$//; + $tounquote =~ s/\\(?=.)//g; + return $tounquote; +} +END_OF_SUB + +# Takes a string and returns it in quoted-printable encoding. +sub quoted_printable { + shift if ref $_[0]; + my $in = shift || ""; + my $out; + GT::Mail::Encoder->gt_encode(encoding => 'quoted-printable', in => $in, out => sub { $out .= $_[0] }); + $out; +} + +# Returns an RFC822 compliant date. +sub RFC822_date (;$$) { + require GT::Date; + GT::Date->import(':timelocal'); + shift if ref $_[0]; + my $time = @_ ? shift : time; + my @lt = localtime($time); + my @ut = gmtime($time); + use integer; + my $tzs = (timegm(@lt) - timelocal(@lt)); + my $tzh = $tzs / 3600; + my $tzm = $tzs % 60 / 60; + my $tz = 100*$tzh + 60*$tzm; + no integer; + sprintf( + "%s, %02d %s %04d %02d:%02d:%02d %+05d", + (qw/Sun Mon Tue Wed Thu Fri Sat/)[$lt[6]], + $lt[3], + (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/)[$lt[4]], + $lt[5] + 1900, + @lt[2,1,0], + $tz + ); +} + +1; + +__END__ + +=head1 NAME + +GT::Mail::BulkMail - A (perhaps overly) simplified interface to sending bulk emails + +=head1 SYNOPSIS + + $mailer = new GT::Mail::BulkMail; + $mailer->option("setting"); + $mailer->otheroption("othersetting"); + ... + + -- or -- + + $mailer = new GT::Mail::BulkMail( + -option => "setting", + -otheroption => "othersetting", + ... + ); + + + + -- then -- + + + sub subroutine { + # Code to generate the next e-mail address + } + open FILE, "email_list.txt"; + %hash = ( 1 => 'some@fictional.address', + 2 => 'who@knows.where' + ); + @array = ('yet@another.fictional.address','and@one.more'); + $mailer->send(\&subroutine,\*FILE,\%hash,\@array); + close FILE; + + +=head1 DESCRIPTION + +GT::Mail::BulkMail is a module to handle mass mailings. It is capable of +using either sendmail, or an SMTP server. It has the advantage of +not requiring multiple connections to the SMTP server. + +=head1 REQUIREMENTS + +Perl 5.004 + +=head2 METHODS + +All methods can be specified at object creation time as an option with the: +S<-option =E value> syntax. For example, C<$mailer = new GT::Mail::BulkMail(-from =E "foo@bar.com")> +would have the same effect as: C<$mailer = new GT::Mail::BulkMail(); $mailer-Efrom("foo@bar.com")> + +=over 4 + +=item smtp + +Sets the SMTP server to use, and sets the object mail sending method to use SMTP. Takes +SMTP server as argument. + +=item sendmail + +Sets the sendmail executable to use. Takes the path to sendmail as the argument. + +=item text + +Specifies that the mail format is text. This translates into Content-type: text/plain. +This is the default format. + +=item html + +Specifies that the mail format is HTML. (Content-type: text/html) + +=item headers + +Returns any custom headers set as a hash reference in scalar context, or a hash in list context. + +=item add_header + +Adds a single header. This can be any header starting with "X-" (Note that X-Mailer headers +will be prepended with the GT::Mail::BulkMail X-Mailer header (which includes the perl version, +OS name, GT::Mail::BulkMail module and CVS versions, and the Gossamer Threads homepage)). Pass +two arguments: A key (header name) and a value (header value). For example, for +C you would use: $mailer->add_header("X-Foo" => "blah blah blah") + +=item add_headers + +Same as above, except it adds multiple headers. Has the same argument format. You would use: +$mailer->add_headers("X-Foo1" => "blah", "X-Foo2" => "blah blah"); + +=item delete_header + +Deletes a single header. Pass the name of the header to delete. + +=item delete_headers + +Delete multiple headers. Pass a list of names of headers to delete. + +=item from + +Sets the "from" field of the e-mail. Must be set before $mailer-Esend() can be called. +Must be set to an e-mail address. If this e-mail address is rejected by the SMTP server, +no e-mails will be sent. + +=item name + +Sets the "name" field of the e-mail. This affects what is displayed in the "From" field. +When sending the email, the actual field will be set to: C<"This name" Esome@name.netE>. +Optional. + +=item subject + +Sets the subject of the message. If not specified, it will default to "(no subject)" + +=item message + +The body of the message. Can be left blank, but that seems rather pointless... +The message will be encoded using the quoted-printable format if it contains characters +outside the 7-bit range. + +=item success + +A code reference to be run for each and every successful e-mail sending. +Each call to this code reference will be given the e-mail address as the only argument +(unless using a message ID, which is discussed below). Optional. + +=item failure + +A code reference that will be run for any email addresses that cannot be sent. Each +call to this code reference will be given the ID or e-mail address as the argument +(message IDs are discussed below). Optional. + +=item frompresend + +=item namepresend + +=item subjectpresend + +=item messagepresend + +A code reference that will be run before sending an e-mail. The 'from', 'name', 'subject', +or 'message' field will be sent to the code references (depending on which method called) +and whatever is returned will be used as the actual field for the email sent. This can be +used to parse fields to customize them for each recipient. The subroutine is called with +two arguments: (ID_OR_EMAIL, FIELD). If an ID is provided, it will be passed as the +first argument, otherwise the email address will be passed. The second argument is the +field itself. The field used in the actual email to the user will be the value returned by +the subroutine. + +The default field (for the rest of the mailing) can be changed by directly modifying $_[1] +itself. + +If the subroutine reference returns an undefined value, the mailer will use the actual field +instead. You can use this technique to only modify some messages, but not others. + +Optional. + +=item show_errors + +If set to something true it will warn() on all errors. Optional. The default is turned on, +but can easily be changed by modifying the line ' + +=item error_code + +Takes a code reference - the code reference will be called with the error as the argument +when an error occurs. Optional. + +=item send + +Takes any number of the following arguments: + +=over 8 + +=item array reference + +An array reference of a list of e-mail addresses to send to. After each message, either the +success or failure callback will be called with the e-mail address as the argument, and +possibly a message as the second argument. + +=item hash reference + +A hash reference of ID =E email pairs. For example, +123 =E 'someone@whoknows.com'. The value will be used as the e-mail address to send +to, and the key will be an identifier to pass into the success or failure callbacks. + +=item glob reference + +A glob reference to an open file. Make sure the file is opened before passing this! +The file should contain one e-mail address per line. + +=item subroutine or code reference + +You may pass a code reference, and it will be called for each e-mail address. It is +assumed that the subroutine will return one e-mail address each time called, and +that a return value of "undef" indicates that there are no more e-mail addresses. +The code reference could alternatively return two items - if it does, it is assumed that +the first is an ID code, and that the second is the email address. When a call to either +or the success or failure callbacks, the ID will be provided as the first argument +instead of the e-mail address itself. + +One cool feature to note about using code refs is that you can call next() from within +the code reference and it will then recall the code reference for the next value. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm new file mode 100644 index 0000000..dbdf6dd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm @@ -0,0 +1,524 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Mail::Editor +# +# Author: Jason Rhinelander +# Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt 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.25 $ =~ /(\d+)\.(\d+)/; + +$ERRORS = { + PARSE => "An error occurred 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("
        \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 "
        \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: + To: + Subject: + Other headers:
        +
        +~; + 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~ +<$FONT>Pre Install Message:
        <$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~
        +<$FONT>Post Install Message:
        <$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~
        +<$FONT>Install Code:<$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~ +<$FONT>Uninstall Code:<$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~ +~; + return $output; +} + +sub install_as_form { +# ---------------------------------------------------------------- +# Returns the install information as a form. +# + my $self = shift; + $self->_load_install; + my $output = qq~ +<$FONT>Pre Install Message:
        + <$FONT> +<$FONT>Post Install Message:
        + <$FONT> +<$FONT>Install Code:
        + <$FONT> +<$FONT>Uninstall Code:
        + <$FONT> +~; + 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~ +<$FONT>$hook_name ($prepost)<$FONT>$code + ~; + } + } + else { + $output = qq~ +<$FONT>No hooks installed + ~; + } + return $output; +} + +sub hooks_as_form { +# ---------------------------------------------------------------- +# Returns plugin hooks as form. +# + my $self = shift; + my $output; + if (@{$self->{hooks}}) { + $output = qq~ +<$FONT>Installed Hooks + ~; + my $i = 0; + foreach my $hook (@{$self->{hooks}}) { + my ($hook_name, $prepost, $code) = @$hook; + $output .= qq~ +<$FONT>$hook_name ($prepost) => $code<$FONT>Delete: + ~; + $i++; + } + } + my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::"; + $output .= qq~ +<$FONT>Add New Hook +<$FONT>Hook: + <$FONT>Code: + ~; + 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~ +<$FONT>$menu_name<$FONT>=> $menu_url + ~; + } + } + else { + $output = qq~ +<$FONT>No Admin Menu options installed + ~; + } + return $output; +} + +sub admin_menu_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (@{$self->{admin_menu}}) { + $output = qq~ +<$FONT>Installed Admin Menu options + ~; + 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~ +<$FONT>$menu_name => $menu_url<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Menu +<$FONT>Name: + <$FONT>URL: + ~; + 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~ +<$FONT>~ . _escape_html($key) . qq~<$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~ + ~; + } + } + else { + $output = qq~ +<$FONT>No user options installed + ~; + } + return $output; +} + +sub options_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (keys %{$self->{options}}) { + $output = qq~ +<$FONT>Installed User options + ~; + my $i = 0; + foreach my $key (sort keys %{$self->{options}}) { + $output .= qq~ +<$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Option +<$FONT>Name: + <$FONT>Default: + ~; + 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~ +<$FONT>$name<$FONT>$size + ~; + $num_files++; + } + } + if (! $num_files) { + $output = qq~ +<$FONT>No extra files installed + ~; + } + 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~ +<$FONT>$name<$FONT>($size) + ~; + $num_files++; + } + } + if ($num_files) { + $output = qq~ +<$FONT>Installed Files +$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 = <{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; + 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm new file mode 100644 index 0000000..d5daca8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm @@ -0,0 +1,266 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt 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.15 $ =~ /(\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', status], ...])"); + } + if (ref $hooks->[0] ne 'ARRAY') { + $hooks = [ $hooks ]; + } + foreach my $hook (@$hooks) { + my ($hookname, $prepost, $action, $status) = @$hook; + if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) { + die "Invalid hook argument. Must be pre/post, not: $prepost"; + } +# Allow a hook to be installed as disabled by default, but for backwards compatibility, it has to be a 0 (not just a false value). + $status = (defined $status and $status ne '' and $status == 0) ? 0 : 1; + push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, $status]; + } + 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 %$opts) { + $registry->{$key} = $opts->{$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', status]); + $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 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 + +=item status + +Whether or not the hook will be enabled or disabled. For backwards +compatibility, if this option is set to anything but '0' then the hook will be +enabled. + +=back + +C returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_menu + +C 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 returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_options + +C 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 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.15 2006/11/22 01:21:14 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm new file mode 100644 index 0000000..9aadb55 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm @@ -0,0 +1,1189 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Manager.pm,v 1.63 2006/10/18 23:59:36 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to manage installed and uninstalled +# plugins. +# + +package GT::Plugins::Manager; +# ================================================================== +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.63 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + cfg => undef, + cgi => undef, + tpl_root => '.', + tpl_prefix => '', + prefix => '', + plugin_dir => undef, + plugin => undef, + plugin_name => undef, + tar => undef, + prog_ver => undef, + prog_reg => undef, + prog_name => undef, + # The program init (e.g. admin) path; if set, this is passed to the plugin + # server and also changes the way download_gossamer() returns errors: + prog_init => undef, + prog_user_cgi => undef, + prog_admin_cgi => undef, + prog_images => undef, + prog_libs => undef, + base_url => undef, + func_url => undef, + path_to_perl => undef, + perl_args => 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}); +} + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to manager"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_man_do') || ''; + my $vars = {}; + my $page = 'plugin_manager_list.html'; + + CASE: { + ($action eq 'pre_install') and do { + $vars = $self->pre_install; + $page = 'plugin_manager_pre_install.html'; + last CASE; + }; + ($action eq 'install') and do { + $vars = $self->install; + last CASE; + }; + ($action eq 'pre_uninstall') and do { + $vars = $self->pre_uninstall; + $page = 'plugin_manager_pre_uninstall.html'; + last CASE; + }; + ($action eq 'uninstall') and do { + $vars = $self->uninstall; + last CASE; + }; + ($action eq 'pre_delete') and do { + $page = 'plugin_manager_delete.html'; + last CASE; + }; + ($action eq 'delete') and do { + $vars = $self->delete; + last CASE; + }; + ($action eq 'hooks') and do { + $vars = $self->set_hooks; + $page = 'plugin_manager_hooks.html'; + last CASE; + }; + ($action eq 'edit_installed') and do { + $vars = $self->edit_installed; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit.html'; + last CASE; + }; + ($action eq 'edit_uninstalled') and do { + $vars = $self->edit_uninstalled; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit_files.html'; + last CASE; + }; + ($action eq 'download') and do { + $page = 'plugin_manager_download.html'; + last CASE; + }; + ($action eq 'download_gossamer') and do { + $page = 'plugin_manager_download.html'; + $vars = $self->download_gossamer; + last CASE; + }; + ($action eq 'download_url') and do { + $vars = $self->download_url; + last CASE; + }; + ($action eq 'download_file') and do { + $vars = $self->download_file; + last CASE; + }; + }; + if ($page eq 'plugin_manager_list.html') { + $vars->{installed} = $self->installed_plugins_html; + $vars->{uninstalled} = $self->uninstalled_plugins_html; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + foreach my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +# ------------------------------------------------------------------------------------------------- # +# Installing/Uninstalling Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub pre_install { +# ---------------------------------------------------------------- +# Display pre-installation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => $GT::Plugins::error }; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return { error => $GT::Plugins::error }; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $pre_code; + { + no strict 'refs'; + $pre_code = ${$plugin_pkg . '::'}{'pre_install'}; + } + my $message = 'No pre installation message supplied.'; + if (defined $pre_code and defined &{$pre_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $pre_code->(); + }; + if ($@) { + $message = "Error running installation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + $message = ${$plugin_pkg . "::error"} || "No error message provided."; + } + } + +# Check for overwriting. + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + if (-e $install_to) { + my $old_plugin = $self->installed_plugin_info($plugin_name); + my $old_version = $old_plugin ? $old_plugin->{version} : "(Can't load installed: $GT::Plugins::error)"; + my $new_plugin = $self->uninstalled_plugin_info($plugin_name); + my $new_version = $new_plugin ? $new_plugin->{version} : "(Can't load uninstalled: $GT::Plugins::error)"; + + return { instructions => $message, old_version => $old_version, new_version => $new_version, confirm => 1 }; + } + else { + return { instructions => $message }; + } +} + +sub install { +# ---------------------------------------------------------------- +# Install the plugin. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_inst = $self->{cgi}->param('skip_install'); + + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + +# Get the main code, and save it. + my $plugin_code = $tar->get_file("$plugin_name.pm") or return { error => "Unable to locate the $plugin_name.pm file in tar" }; + +# Save the code. + open (FILE, "> $install_to") or return { error => "Unable to create plugin file: $install_to. Reason: $!" }; + print FILE $plugin_code->body_as_string; + close FILE; + +# Add the plugin to the config. + delete $self->{cfg}->{$plugin_name}; + + $self->{cfg}->{$plugin_name}->{meta} = $plugin->{meta}; + $self->{cfg}->{$plugin_name}->{version} = $plugin->{version}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Run the install code if requested. + my ($message, $error); + + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $code; + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{install}; + } + if ($self->{cgi}->param('skip_install')) { + $message = "Installation code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $code->($installer, $tar); + }; +# Oh, oh, didn't install properly. + if ($@) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + return { error => "Error running installation code: $@" }; + } + if (! defined $message) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + no strict 'refs'; + $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided. ($@)"; + return { error => "Unable to install plugin: '$message'" }; + } + } + else { + $message = "No installation code found."; + } + +# Move the tar file to the Installed directory. + my $move_from = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + $tar->close_tar; # Need to close the tar file. + + rename($move_from, $move_to) or return { error => "Unable to move plugin from $move_from => $move_to ($!)" }; + +# Installed ok, return results. + if ($error) { + return { error => $error, reload => 1 }; + } + else { + my $output = qq~ +

        Plugin $plugin_name Installed
        +The plugin has been successfully installed.

        +Installation Notes:
        +$message +

        + ~; + return { results => $output, reload => 1 }; + } +} + +sub pre_uninstall { +# ---------------------------------------------------------------- +# Display pre-uninstallation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Installed') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $post_code; + { + no strict 'refs'; + $post_code = ${$plugin_pkg . '::'}{'pre_uninstall'}; + } + my $message = 'No pre uninstallation message supplied.'; + if (defined $post_code and defined &{$post_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $post_code->(); + }; + if ($@) { + $message = "Error running uninstallation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + my $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided."; + } + } + return { instructions => $message }; +} + +sub uninstall { +# ---------------------------------------------------------------- +# Display uninstallation message. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_uninst = $self->{cgi}->param('skip_uninstall'); + my $remove_from = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + my $tar = $self->_open_tar($plugin_name, 'Installed'); + my $move_from = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + if (! $tar) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink($remove_from); + return { error => "Unable to load tar file: $GT::Plugins::error" }; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + if (! $plugin) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $tar->close_tar; + unlink($remove_from); + rename($move_from, $move_to); + return { error => "Unable to load uninstall file: $GT::Plugins::error" }; + } + +# Run any uninstallation code. + my ($code, $output, $error); + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{uninstall}; + } + if ($self->{cgi}->param('skip_uninstall')) { + $output = "Uninstall code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + + local ($@, $SIG{__DIE__}, $^W); + eval { + $output = $code->($installer, $tar); + }; + if ($@) { + $error = "Error in uninstall code: $@"; + } + if (! $output and ! $error) { + $output = "Uninstall completed."; + } + } + else { + $output = "No uninstall code found."; + } + +# Remove the plugin from the config. + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Remove the .pm file. + unlink($remove_from) or return { error => "Unable to remove tar file: $remove_from. Reason: $!" }; + +# Move the tar file back to the Uninstalled directory. + $tar->close_tar; # Need to close the tar file. + rename($move_from, $move_to) or return { error => "Unable to place plugin back into Uninstalled directory: $move_from => $move_to ($!)" }; + + return { results => $output, reload => 1, error => $error }; +} + +# ------------------------------------------------------------------------------------------------- # +# Editing Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub edit_installed { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + if (! exists $self->{cfg}->{$plugin_name}) { + return { error => "Invalid plugin name: $plugin_name" }; + } + +# Update the plugin if requested. + my ($results, $reload); + if ($self->{cgi}->param('edit')) { + my %enabled_hooks = map { $_ => 1 } $self->{cgi}->param('hooks'); + my %enabled_menu = map { $_ => 1 } $self->{cgi}->param('menu'); + if (ref $self->{cfg}->{$plugin_name}->{hooks} eq 'ARRAY') { + my $i = 0; + foreach my $hook (@{$self->{cfg}->{$plugin_name}->{hooks}}) { + $hook->[3] = exists $enabled_hooks{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{menu} eq 'ARRAY') { + my $i = 0; + foreach my $menu (@{$self->{cfg}->{$plugin_name}->{menu}}) { + $menu->[2] = exists $enabled_menu{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{user} eq 'ARRAY') { + + my %opts; + foreach my $option ( @{$self->{cfg}->{$plugin_name}->{user} || []} ) { + $opts{$option->[0]} = $option; + } + + foreach my $key ($self->{cgi}->param()) { + next if ($key !~ /^user-(.+)/); + my $real_key = $1; + my @values = $self->{cgi}->param($key); +# find out if the item is a checkbox, if it is, make sure that it's an arrayref + my $val = (uc($opts{$real_key}->[3]) eq 'CHECKBOX') ? [@values] : $values[0]; + foreach my $opt (@{$self->{cfg}->{$plugin_name}->{user}}) { + if ($opt->[0] eq $real_key) { + $opt->[1] = $val; + } + } + } + } + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $results = "Plugin updated successfully."; + $reload = 1; + } + my $plugin = $self->{cfg}->{$plugin_name}; + my $hooks = $self->load_hooks($plugin_name); + my $menu = $self->load_menu($plugin_name); + my $opts = $self->load_options($plugin_name); + + return { hooks => $hooks, menu => $menu, options => $opts, %{$plugin->{meta}}, results => $results, reload => $reload }; +} + +sub edit_uninstalled { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => "Unable to open tar file: $GT::Plugins::error" }; + my $base = $self->{base_url}; + my ($output, $results, $body, $body_name); + + my $error = ''; + my $delete = $self->{cgi}->param('delete'); + if ($delete) { + $tar->remove_file($delete); + $tar->write ? ($results = "File $delete has been successfully removed!") : ($error = "Unable to delete file: $GT::Tar::error"); + } + my $add = $self->{cgi}->param('add'); + if ($add) { + my $body = $self->{cgi}->param('filebody'); + $tar->add_data(name => $add, body => $body); + $tar->write ? ($results = "File $add successfully added.") : ($error = "Unable to add file: $GT::Tar::error"); + } + my $edit = $self->{cgi}->param('edit'); + if ($edit) { + my $file = $tar->get_file($edit); + if ($file) { + $body = $file->body_as_string; + $body = $self->{cgi}->html_escape($body); + $body_name = $file->name; + } + } + my $save = $self->{cgi}->param('save'); + if ($save) { + my $file = $tar->get_file($save); + if ($file) { + my $body = $self->{cgi}->param('body'); + $body =~ s/\r//g; + $file->body($body); + $tar->write ? ($results = "File $save updated successfully.") : ($error = "Unable to save file: $GT::Tar::error"); + } + } + my $perl = $self->{cgi}->param('perl'); + if ($perl) { + my $file = $tar->get_file($perl); + if ($file) { + $results = $self->_syntax_check($file); + } + } + my $files = $tar->files; + + foreach my $file (@$files) { + my $name = $file->name; + next if ($name eq 'Wizard.pm'); + my $size = length $file->body_as_string; + + $output .= qq~ +$name ($size bytes) + + Edit | + Perl Check + ~; + $output .= qq~ + | Delete + ~ if (($name ne 'Install.pm') and ($name ne $plugin_name . '.pm')); + $output .= qq~ + + + ~; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or ($error = "Unable to load install file: $GT::Plugins::error"); + $plugin->{meta} ||= {}; + $plugin->{meta}->{title} ||= $plugin_name; + $plugin->{meta}->{author} ||= 'Unknown'; + $plugin->{meta}->{url} ||= ''; + $plugin->{meta}->{description} ||= ''; + $plugin->{version} ||= 'Unknown'; + return { files => $output, %{$plugin->{meta}}, results => $results, body => $body, body_name => $body_name, inst_error => $error }; +} + +sub load_menu { +# ----------------------------------------------------------------- +# Returns the html to enable/disable admin menu options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{menu} eq 'ARRAY'); + my $output = qq~ +Menu Options (show/hide) + ~; + my $i = 0; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + my ($menu, $url, $enabled) = @$menu_option; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $menu + ~; + $i++; + } + return $output; +} + +sub load_hooks { +# ----------------------------------------------------------------- +# Returns the html to enable/disable hooks. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{hooks} eq 'ARRAY'); + my $output = qq~ +Plugin Hooks (enable/disable) + ~; + my $i = 0; + + foreach my $hook (@{$self->{cfg}->{$plugin}->{hooks}}) { + my ($hookname, $prepost, $action, $enabled) = @$hook; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $hookname ($prepost) + ~; + $i++; + } + return $output; +} + +sub load_options { +# ----------------------------------------------------------------- +# Returns the html to enable/disable plugin options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{user} eq 'ARRAY'); + my $output = qq~ +Plugin Options + ~; + + # This may be changed in the future + require GT::SQL::Display::HTML; + my $HTML = GT::SQL::Display::HTML->new(); + foreach my $option (@{$self->{cfg}->{$plugin}->{user}}) { + my ($name, $val, $ins, $type, $names, $values, $form_size) = @$option; + + $type ||= 'text'; $type = lc( $type ); + my $options = {}; + foreach my $i ( 0 .. $#$names ) { $options->{ $values->[$i] } = $names->[$i]; } + + no strict 'refs'; + my $form_element = $HTML->$type( { name => "user-$name", value => $val, values => $options, def => { form_size => $form_size } } ); + use strict; + + if ($ins) { + $output .= qq~$ins~; + } + + $output .= qq~ + + $name + $form_element + + ~; + +# if ($ins) { +# $output .= qq~$ins~; +# } +# +# $output .= qq~ +# +# $name +# +# +# ~; + } + + return $output; +} + +# ------------------------------------------------------------------------------------------------- # +# Removing Files # +# ------------------------------------------------------------------------------------------------- # + +sub delete { +# ---------------------------------------------------------------- +# Remove a plugin completely from the Uninstalled dir. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + return unlink($file) ? { results => "Plugin successfully removed." } : { error => "Unable to remove plugin: $file. Reason: $!" }; +} + +# ------------------------------------------------------------------------------------------------- # +# Downloading Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub download_gossamer { + my $self = shift; + + require GT::WWW; + require GT::Date; + + my $reg_number = $self->{prog_reg}; + my $url = "http://www.gossamer-threads.com/perl/updates/plugin.cgi"; + my $mh = 10; + my $nh = $self->{cgi}->param('nh') || 1; + my $beg = $nh == 1 ? 0 : $mh * ($nh - 1); + my $www = GT::WWW->new( + protocol => 'http', + host => 'www.gossamer-threads.com', + path => '/perl/updates/plugin.cgi', + parameters => [ + product => $self->{prog_name}, + product_version => $self->{prog_ver}, + reg_number => $reg_number, + sb => $self->{cgi}->param('sb') || 'plugin_name', + so => $self->{cgi}->param('so') || 'asc', + $self->{prog_init} ? (init_path => $self->{prog_init}) : (), + ] + ); + my $page = $www->get or return { error => "Unable to contact Gossamer Threads: " . $www->error() . ". Please try again later." }; + my @plugins = split /\n/, $page; + my $status_line = shift @plugins; + my ($status) = $status_line =~ /^# Status: (\w+)$/; + + if ($status ne 'ok') { + if (!$self->{prog_init}) { + # Old products - they only expect a single error tag containing the error message + return { error => "You are not authorized to connect to the plugin server. Please contact support\@gossamer-threads.com for more information and reference status: '$status'." }; + } + else { + # New programs just get the error_code and format their own message in the template. + # Error codes: + # admin_path_mismatch_reset - the stored admin path does not match; it can be reset from the license area + # admin_path_mismatch - the stored admin path does not match; no resets are available + # invalid_product_id - the 'product' provided is unknown by the plugin server + return { error_code => $status }; + } + } + + my $plugin_cfg = do "$self->{plugin_dir}/plugin.cfg" || {}; + my $count = 0; + my $hits = $#plugins + 1; + my (@output, $speedbar, $html); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ +
        + + + + + + + ~; + foreach my $p (@plugins) { + $count++; + next if $nh > 1 and $count < $beg + 1; + + my %row; + ($row{plg_id}, $row{plg_name}, $row{plg_version}, $row{plg_url}, $row{plg_support}, $row{plg_support_url}, $row{plg_language}, $row{plg_updated}, $row{plg_license}, $row{plg_price}, $row{plg_author}, $row{cli_id_fk}, $row{author_name}, $row{plg_description}) = split /\t/, $p; + $row{plg_updated} = GT::Date::date_get($row{plg_updated}, "%ddd%, %mmm% %dd% %yyyy% %hh%:%MM%:%ss%") if $row{plg_updated}; + + my $fetch = "$url/$row{plg_name}.tar?id=$row{plg_id};reg_number=$reg_number"; + $row{download_url} = $self->{cgi}->escape($fetch); + $row{installed} = $plugin_cfg->{$row{plg_name}} ? $plugin_cfg->{$row{plg_name}}->{version} : ''; + push @output, \%row; + + my $price = $row{plg_license} == 2 ? $row{plg_price} : 'Free'; + $output .= qq~ + + + + + + ~; + last if @output == $mh; + } + if ($hits > $mh) { + my $pages = int($hits / $mh); + $pages++ if $hits % $mh; + for my $i (1..$pages) { + $self->{cgi}->param('nh', $i); + my $url = $self->{cgi}->url; + $speedbar .= $i == $nh ? "$i " : "$i "; + } + } + $output = qq~ +

        <$font>There are $hits plugins available for download.

        + $speedbar + $output +
        <$font>Plugin Name<$font>Latest Version<$font>Action
        + <$font>$row{plg_name}
        + Author: $row{author_name}
        + Last Updated: $row{plg_updated}
        + Description:
        $row{plg_description}
        + Price: $price + +
        <$font>$row{plg_version}<$font>Download
        +
        + $speedbar + ~; + return { plugins => \@output, num_plugins => $hits, speedbar => $speedbar, base_url => $self->{base_url}, gossamer => $output }; +} + +sub download_file { +# ------------------------------------------------------------------- +# Place the upload file into the Uninstalled directory. +# + my $self = shift; + my $file = $self->{cgi}->param('file'); + if (! $file) { + return { error => "Please press browse to pick a file before uploading." }; + } + my ($name) = $file =~ m,([^/\\]+)$,; + if ($name !~ /^[\w\-\.]+\.tar$/) { + return { error => "Invalid file name: $name. Must be a .tar file, and only be letters and numbers, no spaces." }; + } + my $full_path = $self->{plugin_dir} . "/Uninstalled/" . $name; + open (FILE, "> $full_path") or return { error => "Unable to create file: $full_path ($!)" }; + binmode FILE; # Output stream + binmode $file; # Input stream + my ($read, $buffer); + while ($read = read($file, $buffer, 4096)) { + print FILE $buffer; + } + close FILE; + + return { results => "File was uploaded successfully." }; +} + +sub download_url { +# ------------------------------------------------------------------- +# Fetch a plugin from a URL and save it to the folder. +# + my $self = shift; + my $url = $self->{cgi}->param('url'); + $url or return { error => "Please enter a valid url." }; + require GT::WWW; + my ($protocol) = GT::WWW->parse_url($url); + return { error => "Invalid URL specified" } unless $protocol; + + unless (GT::WWW->protocol_supported($protocol)) { + return { error => "Unsupported protocol entered: $protocol" }; + } + + my ($fh, $plugin_file, $full_path, $plugin_error, $status_error, $open_error, $no_filename, $print_error); + my $www = GT::WWW->new($url); + $www->chunk_size(16 * 1024); # Get 16KB at a time + $www->chunk(sub { + my $chunk = shift; + unless ($fh or defined $plugin_error) { + my $response = $www->response; + my $status = $response->status; + my $header = $response->header; + if ($status_error = not $status) { + $www->cancel; + return; + } + if ($header->contains('X-Plugins' => 'Error')) { + $plugin_error = ''; + } + else { + $plugin_file = {$header->header_words('Content-Disposition')}->{filename}; + unless ($plugin_file) { + if (!$www->query_string) { + my $path = $www->path; + ($plugin_file) = $path =~ m{/([^/]+)\.tar$}; + $plugin_file .= ".tar" if $plugin_file; + } + unless ($plugin_file) { + $open_error = "No plugin found at url: $url"; + $no_filename = 1; + $www->cancel; + return; + } + } + $fh = \do { local *PLUGIN; *PLUGIN }; + $full_path = "$self->{plugin_dir}/Uninstalled/$plugin_file"; + unless (open $fh, "> $full_path") { + $open_error = "Unable to create file '$full_path': $!"; + $www->cancel; + return; + } + binmode $fh; + } + } + if (defined $plugin_error) { $plugin_error .= $$chunk } + else { + unless (print $fh $$chunk) { + $print_error = "Unable to continue writing to file '$full_path': $!. Removing partial file."; + $www->cancel; + unlink $full_path; + } + } + }); + + my $response = $www->get or return { error => "Unable to retrieve plugin: " . $www->error }; + $status_error and return { error => "Unable to retrieve plugin: Server returned error status: " . (int $response->status) . $response->status }; + defined $plugin_error and return { error => $plugin_error }; + $open_error and return { error => $open_error }; + $print_error and return { error => $print_error }; + + return { results => "Plugin $plugin_file retrieved successfully." }; +} + +# ------------------------------------------------------------------------------------------------- # +# Utilities # +# ------------------------------------------------------------------------------------------------- # + +sub admin_menu { +# ---------------------------------------------------------------- +# Displays the admin menu. +# + my $self = shift; + my $menu = ''; + foreach my $plugin (sort keys %{$self->{cfg}}) { + next unless ($self->{cfg}->{$plugin}->{menu}); + $menu .= qq~ + +  $plugin
        + ~; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + next if (defined $menu_option->[2] and ! $menu_option->[2]); + $menu .= qq~  
        $menu_option->[0]
        ~; + } + $menu .= " "; + } + if ($menu) { + $menu = qq~ + +  Installed + Plugins + + $menu + ~; + } + return $menu; +} + +sub admin_menu_items { +# ----------------------------------------------------------------------------- +# Returns tags meant for a template to reproduce the above menu. In +# particular, you get a 'plugin_menus' loop which has a 'plugin_name' key and +# 'plugin_menu' loop; plugin_menu contains two keys - name and url. +# + my $self = shift; + my @plugins; + for my $plugin (sort keys %{$self->{cfg}}) { + next unless $self->{cfg}->{$plugin}->{menu}; + push @plugins, { plugin_name => $plugin }; + for my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + next if defined $menu_option->[2] and not $menu_option->[2]; + push @{$plugins[-1]->{plugin_menu}}, { name => $menu_option->[0], url => $menu_option->[1] }; + } + } + return { plugin_menus => \@plugins }; +} + +sub installed_plugins { +# ---------------------------------------------------------------- +# Returns a list of installed plugins, not formatted. +# + my $self = shift; + my $plgs = {}; + foreach my $plugin (keys %{$self->{cfg}}) { + next if (substr($plugin, 0, 1) eq '_'); + $plgs->{$plugin} = $self->{cfg}->{$plugin}; + } + return $plgs; +} + +sub installed_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of installed plugins. +# + my $self = shift; + my $plugins = $self->installed_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; +# Show installed plugins. + my $base = $self->{base_url}; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Installed Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title<$font>$version<$font>$author<$font>Edit | + Uninstall
        "; + if (! $count) { + $html = "
        No plugins have been installed.
        "; + } + return $html; +} + +sub uninstalled_plugins { +# ---------------------------------------------------------------- +# Returns a list of uninstalled plugins, not formatted. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!); + while (defined(my $file = readdir(DIR))) { + next unless ($file =~ /^(.+)\.tar$/); + my $plugin_name = $1; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled'); + $tar or $plugins{$plugin_name} = { tar_error => $GT::Plugins::error } and next; + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + $plugin or $plugins{$plugin_name} = { inst_error => $GT::Plugins::error } and next; + $plugins{$plugin_name} = $plugin; + } + closedir(DIR); + return \%plugins; +} + +sub uninstalled_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of uninstalled plugins. +# + my $self = shift; + my $plugins = $self->uninstalled_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; + my $base = $self->{base_url}; + my $func = $self->{func_url} ? $self->{func_url} : "$base&do=plugin"; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + my $tar_err = $plugin->{tar_error} || ''; + my $inst_err = $plugin->{inst_error} || ''; + my $inst_l = qq~Install |~; + my $edit_l = qq~Edit |~; + my $error = ''; + if ($tar_err) { + $error = "
        $tar_err"; + $inst_l = ''; + $edit_l = ''; + } + if ($inst_err) { + $error = "
        $inst_err"; + $inst_l = ''; + } + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Uninstalled Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title$error<$font>$version<$font>$author<$font>$inst_l $edit_l + Delete + | Download
        "; + if (! $count) { + $html = "
        No plugins are available to be installed.
        "; + } + return $html; +} + +sub uninstalled_plugin_info { +# ---------------------------------------------------------------- +# Returns a hash of plugin info for an uninstalled plugin. +# + my ($self, $plugin_name) = @_; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + if (! -e $file) { + return $self->error('CANTOPEN', 'WARN', $file, $!); + } + my $tar = GT::Tar->open($file) or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + return $plugin; +} + +sub installed_plugin_info { +# ---------------------------------------------------------------- +# Return a hash of plugin info for an installed plugin. +# + my ($self, $plugin_name) = @_; + return exists $self->{cfg}->{$plugin_name} ? + $self->{cfg}->{$plugin_name} : + $self->error('NOPLUGIN', 'WARN', $plugin_name); +} + +sub _open_tar { +# ---------------------------------------------------------------- +# Opens a tar file. +# + my ($self, $plugin_name, $dir) = @_; + my $file = $self->{plugin_dir} . '/' . $dir . '/' . $plugin_name . '.tar'; + if (! -e $file) { + return $self->error('CANTLOAD', 'WARN', $file, $!); + } + my $tar = GT::Tar->open( $file ) or return $self->error('CANTLOAD', 'WARN', $file, "Unable to parse tar file: $GT::Tar::error"); + return $tar; +} + +sub _load_plugin_install { +# ---------------------------------------------------------------- +# Takes a .tar file, looks for an Install.pm file, evals it, and +# returns a hash of meta info. +# + my ($self, $tar, $plugin_name) = @_; + my $install = $tar->get_file('Install.pm') or return $self->error('CANTLOAD', 'WARN', $plugin_name, "No Install.pm file found in tar!"); + +# Eval the install file. + my $file = $install->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $plugin_name, "Install.pm does not compile: $@"); + } + } + +# Load the meta info. + no strict 'refs'; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + my $version = ${$plugin_pkg . "::VERSION"}; + + my $meta = defined ${$plugin_pkg . '::META'} ? ${$plugin_pkg . '::META'} : {}; + if (! defined $version) { + $version = defined $meta->{version} ? $meta->{version} : 'UNKNOWN'; + } + my $author = defined $meta->{author} ? $meta->{author} : 'Unknown'; + my $url = defined $meta->{url} ? $meta->{url} : 'Unknown'; + my $desc = defined $meta->{description} ? $meta->{description} : 'None'; + + return { name => $plugin_name, meta => $meta, author => $author, url => $url, description => $desc, version => $version }; +} + +sub _syntax_check { +# ------------------------------------------------------------------- +# Returns the output of syntax checking the current file. +# + my $self = shift; + my $file = shift; + my $results; + + require GT::TempFile; + if ($self->{path_to_perl} and -x $self->{path_to_perl}) { + my $tmp_file = new GT::TempFile; + open (TMPFILE, "> $$tmp_file") or return "Couldn't open temp file: $$tmp_file ($!)"; + print TMPFILE $file->body_as_string; + close TMPFILE; + + my $args = $self->{perl_args} || ''; + +# We are not really running under mod_perl in the spawned perl check. +# DBI will not load if it thinks we are (but aren't). + local($ENV{GATEWAY_INTERFACE}, $ENV{MOD_PERL}); + my $perl_results = `$self->{path_to_perl} $args $$tmp_file 2>&1`; + my $filename = $file->name; + $perl_results =~ s/$$tmp_file/$filename/g; + + $results = "Perl Said:
        $perl_results
        "; + } + else { + $results = "Unable to execute perl: $self->{path_to_perl}"; + } + return $results; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm new file mode 100644 index 0000000..a1447a6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm @@ -0,0 +1,1098 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Wizard.pm,v 1.34 2005/04/14 07:43:48 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to install/uninstall/edit plugins. +# + +package GT::Plugins::Wizard; +# ================================================================== +use strict; +use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/; +use GT::Base; +use GT::Plugins; +use GT::Tar; +use GT::Dumper; + +$ERROR_MESSAGE = 'GT::Plugins'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + prefix => '', + cgi => undef, + initial_indent => ' ', + tpl_root => '.', + tpl_prefix => '', + plugin_dir => undef, + plugin => undef, + tar => undef, + prog_ver => undef, + install_header => undef, + dirs => {}, + oo => undef +}; +@ISA = qw/GT::Base/; + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to wizard"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to wizard"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_wiz_do') || ''; + my $vars = {}; + my $page = 'plugin_wizard_step1.html'; + my $plugin = $self->{cgi}->param('plugin_name'); + $self->load_plugin($plugin) if ($plugin); + + CASE: { +# Meta Information + ($action eq 'step2') and do { + $vars = $self->_validate_step1(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step1.html'; last CASE } + $vars = $self->_load_step2(); + $page = 'plugin_wizard_step2.html'; + last CASE; + }; +# Plugin Hooks + ($action eq 'step3') and do { + $vars = $self->_validate_step2() unless ($self->{cgi}->param('skip_validate')); + if (defined $vars->{error}) { $page = 'plugin_wizard_step2.html'; last CASE } + $vars = $self->_load_step3(); + $page = 'plugin_wizard_step3.html'; + last CASE; + }; +# Admin Menu Options. + ($action eq 'step4') and do { + $vars = $self->_validate_step3(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step3.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step3.html'; last CASE } + $vars = $self->_load_step4(); + $page = 'plugin_wizard_step4.html'; + last CASE; + }; +# User Options. + ($action eq 'step5') and do { + $vars = $self->_validate_step4(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step4.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step4.html'; last CASE } + $vars = $self->_load_step5(); + $page = 'plugin_wizard_step5.html'; + last CASE; + }; +# Included Files. + ($action eq 'step6') and do { + $vars = $self->_validate_step5(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step5.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step5.html'; last CASE } + $vars = $self->_load_step6(); + $page = 'plugin_wizard_step6.html'; + last CASE; + }; +# All Done. + ($action eq 'step7') and do { + $vars = $self->_validate_step6(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step6.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step6.html'; last CASE } + $vars = $self->_load_step7(); + $page = 'plugin_wizard_step7.html'; + last CASE; + }; +# Create the plugin and finish. + ($action eq 'create') and do { + $vars = $self->_validate_step7(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_install(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_code(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $page = 'plugin_wizard_step8.html'; + last CASE; + }; + +# Get a list of plugins that can be edited. + $vars->{edit} = $self->_list_editable; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + for my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +sub load_plugin { +# ---------------------------------------------------------------- +# Loads a plugin. +# + my ($self, $plugin_name) = @_; + $self->{plugin}->{name} = $plugin_name; + return unless (defined $plugin_name and $plugin_name =~ /^\w{2,20}$/); + + $self->{tar} = $self->_load_tar; + $self->_load_plugin; + return 1; +} + +sub save_plugin { +# ------------------------------------------------------------------- +# Saves the plugin back to disk. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm'); + if (! $wizard) { + $self->{tar}->add_data(name => 'Wizard.pm', body => $self->_create_wizard); + } + else { + $wizard->body($self->_create_wizard); + } + return $self->{tar}->write; +} + +sub _get_hook_params { +# ------------------------------------------------------------------------------ + my $hook = shift; + my $param = shift; + my %results; + for my $e (@$hook) { + my $val = ref $e->{$param} ? join(", ", @{$e->{$param}}) : $e->{$param}; + $results{$val}++; + } + return sort keys %results; +} + +sub _validate_step1 { +# ------------------------------------------------------------------- +# Checks that the plugin name is valid. +# + my $self = shift; + my $name = $self->{cgi}->param('plugin_name'); + $name or return { error => "Please enter a valid plugin name." }; + $name =~ /^\w{2,20}$/ or return { + error => "Plugin names must be only letters and numbers, and be between 2 and 20 characters." + }; + $self->save_plugin or return { error => $GT::Plugins::error }; + return { plugin_name => $name }; +} + +sub _load_step2 { +# ------------------------------------------------------------------- +# Preloads vars for meta information. +# + my $self = shift; + return defined $self->{plugin}->{meta}->{prog_ver} + ? $self->{plugin}->{meta} + : { %{$self->{plugin}->{meta}}, prog_ver => $self->{prog_ver} }; +} + +sub _validate_step2 { +# ------------------------------------------------------------------- +# Validates the meta information. +# + my $self = shift; + my $version = $self->{cgi}->param('version'); + $version or return { error => "Please make sure you enter a version, perhaps start with 0.0.1 to begin." }; + $version =~ /^[\d\.]+$/ or return { error => "Version numbers should contain only numbers and periods." }; + + my $author = $self->{cgi}->param('author'); + $author or return { error => "Please make sure you enter an author." }; + + my $url = $self->{cgi}->param('url'); + + my $license = $self->{cgi}->param('license'); + $license or return { error => "Please make sure you enter in a license style." }; + + my $prog_ver = $self->{cgi}->param('prog_ver'); + $prog_ver or return { + error => 'Please enter a program version that your plugin will require. Set to 1 for all versions. ' . + 'This is useful to ensure the plugin user has the required version before using the plugin.' + }; + + my $description = $self->{cgi}->param('description'); + + $self->{plugin}->{meta} = { + version => $version, + author => $author, + url => $url, + license => $license, + description => $description, + prog_ver => $prog_ver + }; + + $self->save_plugin or return { error => $GT::Plugins::error }; + + return {}; +} + +sub _load_step3 { +# ------------------------------------------------------------------- +# Preloads vars for hook information. +# + my $self = shift; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + +# try to load the hook config file + return { hooks => '' } unless defined $self->{plugin}->{hooks} and @{$self->{plugin}->{hooks}}; + + my $output = qq~ + + + + + + ~; + + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + my ($name, $type, $code, $position) = @$hook; + $output .= qq~ + + + + + + ~; + } + $output .= qq~ +
        <$font>Hook<$font>Type<$font>Code<$font>Position
        <$font> $name<$font>$type<$font>$code<$font>$position
        + ~; + return { hooks => $output }; +} + +sub _validate_step3 { +# ------------------------------------------------------------------- +# Validate any new hooks that were added. +# + my $self = shift; + $self->{plugin}->{hooks} ||= []; + +# Remove unwanted hooks. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + if ($id eq $del_id) { + $results .= "
      • Plugin hook " . $hook->[0] . " successfully removed."; + splice @{$self->{plugin}->{hooks}}, $i, 1; + } + $i++; + } + } + } +# Add new hooks + my $add_hook = $self->{cgi}->param('name'); + if ($add_hook) { + my $add_code = $self->{cgi}->param('code'); + my $add_type = $self->{cgi}->param('type'); + my $add_pos = $self->{cgi}->param('pos'); # Not used; future use? + push @{$self->{plugin}->{hooks}}, [$add_hook, $add_type, $add_code, $add_pos]; + $results .= "
      • Plugin hook $add_hook successfully added."; + } + my $hooks = $self->_load_step3; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", hooks => $hooks->{hooks} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more hooks to delete.", hooks => $hooks->{hooks} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, hooks => $hooks->{hooks} }; + } + return {}; +} + +sub _load_step4 { +# ------------------------------------------------------------------- +# Preloads vars for admin menu options. +# + my $self = shift; + return { menu => '' } unless $self->{plugin}->{menu} and @{$self->{plugin}->{menu}}; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Name<$font>URL
        <$font> $name<$font>$url
        + ~; + return { menu => $output }; +} + +sub _validate_step4 { +# ------------------------------------------------------------------- +# Validate any new menu that were added. +# + my $self = shift; + $self->{plugin}->{menu} ||= []; + +# Remove unwanted menu. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + if ($name eq $del_id) { + splice @{$self->{plugin}->{menu}}, $i, 1; + $results .= "
      • Menu Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new menu + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_url = $self->{cgi}->param('url'); + $self->{plugin}->{menu} ||= []; + push @{$self->{plugin}->{menu}}, [$add_name, $add_url]; + $results .= "
      • Menu Option $add_name successfully added."; + } + + my $menu = $self->_load_step4; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", menu => $menu->{menu} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more admin menu to delete.", menu => $menu->{menu} }; + } + + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, menu => $menu->{menu} }; + } + return {}; +} + +sub _load_step5 { +# ------------------------------------------------------------------- +# Preloads vars for user options. +# + my $self = shift; + return { user => '' } unless (defined $self->{plugin}->{user} and @{$self->{plugin}->{user}}); + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + + + + + ~; + + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $instructions, $form_type, $form_names, $form_values ) = @$opt; + $form_values = @$form_values + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_values) . "
        " + : " "; + $form_names = @$form_names + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_names) . "
        " + : " "; + my $ins = $self->{cgi}->html_escape($instructions); + $val = $self->{cgi}->html_escape($val); + $output .= qq~ + + + + + + + + +~; + } + $output .= qq~
        <$font>Name<$font>Value<$font>Instructions<$font>Form Type<$font>Form Names<$font>Form Value
        <$font> $name<$font>$val<$font>$ins <$font>$form_type<$font>$form_names<$font>$form_values
        ~; + + return { user => $output }; +} + +sub _validate_step5 { +# ------------------------------------------------------------------- +# Validate any user options that were added. +# + my $self = shift; + $self->{plugin}->{user} ||= []; + +# Remove unwanted user options. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $ins) = @$opt; + if ($name eq $del_id) { + splice @{$self->{plugin}->{user}}, $i, 1; + $results .= "
      • User Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new user option + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_val = $self->{cgi}->param('value'); + my $add_ins = $self->{cgi}->param('instructions'); + my $form_names = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_names') ]; + my $form_values = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_values') ]; + my $form_type = $self->{cgi}->param('form_type'); + push @{$self->{plugin}->{user}}, [ $add_name, $add_val, $add_ins, $form_type, $form_names, $form_values ]; + $results .= "
      • User Option $add_name successfully added."; + } + my $user = $self->_load_step5; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", user => $user->{user} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more user option to delete.", user => $user->{user} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, user => $user->{user} }; + } + return {}; +} + +sub _load_step6 { +# ------------------------------------------------------------------- +# Preloads any user included files. +# + my $self = shift; + return { files => '' } unless (defined $self->{plugin}->{files} and @{$self->{plugin}->{files}}); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + my %seen; + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $location) = @$file; + my $id = join("|", @$file); + next if $name eq "$self->{plugin}->{name}.pm"; + if (exists $self->{dirs}->{$location}) { + $location = $self->{dirs}->{$location}; + } + $seen{$name}++; + $output .= qq~ + + + + ~; + } + my $files = $self->{tar}->files; + for my $file (@$files) { + my $name = $file->name; + my $id = $name . '|'; + + next if $seen{$name} or $name eq 'Wizard.pm' or $name eq 'Install.pm' or $name eq "$self->{plugin}->{name}.pm"; + + push @{$self->{plugin}->{files}}, [$name, '']; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Filename<$font>Location
        <$font> $name<$font>$location
        <$font> $name<$font>Unknown (not added in Wizard)
        + ~; + return { files => $output }; +} + +sub _validate_step6 { +# ------------------------------------------------------------------- +# Receives files and stores them in the tar file. +# + my $self = shift; + my $results = ''; + $self->{plugin}->{files} ||= []; + +# Remove any existing files. + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $file (@{$self->{plugin}->{files}}) { + my $id = join("|", @$file); + if ($id eq $del_id) { + my $name = $file->[0]; + $self->{tar}->remove_file($name); + $self->{tar}->write; + splice @{$self->{plugin}->{files}}, $i, 1; + $results .= "
      • File " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add any new attachments. + my $filename = $self->{cgi}->param('name'); + if ($filename) { + my $filehandle = $self->{cgi}->param('file'); + my $body = $self->{cgi}->param('add_body'); + my $location = $self->{cgi}->param('location'); + if (ref $filehandle) { + $body = ''; + my ($buffer, $read); + while ($read = read($filehandle, $buffer, 4096)) { + $body .= $buffer; + } + } + $body ||= ' '; + $body =~ s/\r//g; + push @{$self->{plugin}->{files}}, [$filename, $location]; + my $res = $self->{tar}->add_data(name => $filename, body => $body); + $results .= "File $filename attached successfully."; + } + my $file = $self->_load_step6; + $self->save_plugin or return { error => $GT::Plugins::error }; + + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", files => $file->{files} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more file to delete.", files => $file->{files} }; + } + if ($results) { + return { results => $results, files => $file->{files} }; + } + return {}; +} + +sub _load_step7 { +# ------------------------------------------------------------------- +# Fetches the install/uninstall message. +# + my $self = shift; + return { + install => $self->{plugin}->{install}, + uninstall => $self->{plugin}->{uninstall}, + install_code => $self->{plugin}->{install_code}, + uninstall_code => $self->{plugin}->{uninstall_code} + }; +} + +sub _validate_step7 { +# ------------------------------------------------------------------- +# Saves the install/uninstall message. +# + my $self = shift; + $self->{plugin}->{install} = $self->{cgi}->param('install'); + $self->{plugin}->{uninstall} = $self->{cgi}->param('uninstall'); + $self->{plugin}->{install_code} = $self->{cgi}->param('install_code'); + $self->{plugin}->{uninstall_code} = $self->{cgi}->param('uninstall_code'); + $self->save_plugin or return { error => $GT::Plugins::error }; + return {}; +} + +sub _create_code { +# ------------------------------------------------------------------- +# Creates the code file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + $self->{install_header} ||= ''; + my $stubs = $self->_create_stubs; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== + +$self->{initial_indent}use strict; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +# Inherit from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +# Your code begins here. +$stubs + +# Always end with a 1. +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file($self->{plugin}->{name} . '.pm'); + if ($file) { + my $overwrite = $self->{cgi}->param('overwrite'); + my $skip = $self->{cgi}->param('skip'); + if (! $overwrite and ! $skip) { + return { error => "Overwrite the existing $self->{plugin}->{name}.pm:
        " }; + } + $file->body($output) if ($overwrite); + } + else { + $self->{tar}->add_data( name => $self->{plugin}->{name} . '.pm', body => $output ); + } + $self->{tar}->write; + return {}; +} + +sub _create_install { +# ------------------------------------------------------------------- +# Creates the install.pm file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + (my $qversion = $version) =~ s/(?=['\\])/\\/g; + + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{plugin}->{meta}); + my $inst_mess = GT::Dumper->dump(var => 'my $inst_msg', data => $self->{plugin}->{install}); + my $uninst_mess = GT::Dumper->dump(var => 'my $uninst_msg', data => $self->{plugin}->{uninstall}); + my $install = $self->_create_install_func; + my $uninstall = $self->_create_uninstall_func; + + for ($meta_dump, $inst_mess, $uninst_mess, $install, $uninstall) { s/\r//g } + + my $inst_code = $self->{plugin}->{install_code} || ''; + $inst_code =~ s/\r//g; + $inst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + my $uninst_code = $self->{plugin}->{uninstall_code} || ''; + $uninst_code =~ s/\r//g; + $uninst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + $self->{install_header} ||= ''; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== +$self->{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$VERSION \$DEBUG \$NAME \$META/; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +$self->{initial_indent}\$VERSION = '$qversion'; +$self->{initial_indent}\$DEBUG = 0; +$self->{initial_indent}\$NAME = '$self->{plugin}->{name}'; +# Inhert from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +$self->{initial_indent}$meta_dump + +sub pre_install { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they install the plugin. +# + $inst_mess + return \$inst_msg; +} + +sub pre_uninstall { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they remove the plugin. +# + $uninst_mess + return \$uninst_msg; +} + +sub install { +# ----------------------------------------------------------------------------- +# This function does the actual installation. Its first argument is a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. The second argument is a GT::Tar object which you can use to access any +# files in your plugin module. +# +# You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$Plugins::$self->{prefix}$self->{plugin}->{name}::error +# + my (\$mgr, \$tar) = \@_; + $install + $inst_code + return "The plugin has been successfully installed!"; +} + +sub uninstall { +# ----------------------------------------------------------------------------- +# This function removes the plugin. Its first argument is also a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$${plugin_pkg}::error +# + my \$mgr = shift; + $uninstall + $uninst_code + return "The plugin has been successfully removed!"; +} + +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file('Install.pm'); + if ($file) { + $file->body($output); + } + else { + $self->{tar}->add_data(name => 'Install.pm', body => $output); + } + $self->{tar}->write; + return {}; +} + +sub _esc { +# ------------------------------------------------------------------- + $_[0] =~ s/'/\\'/g; + $_[0] =~ s/\n/\\\n/g; + $_[0] =~ s/\r//g; + return; +} + +sub _create_install_func { +# ------------------------------------------------------------------- +# Creates the install function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + + $code .= qq~\n \$mgr->install_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~\n \$mgr->install_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + $code .= qq~\n \$mgr->install_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + if (@{$self->{plugin}->{files}}) { + $code .= qq~ + +# Silence warnings + \$GT::Tar::error ||= ''; + +# The following section will unarchive attached files into the proper location. + my \$file;~; + } + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $loc) = @$file; + next if ($name eq $self->{plugin}->{name} . '.pm'); + next if ($name eq 'Install.pm'); + my $path = ''; + if (exists $self->{dirs}->{$loc}) { + $path = $self->{dirs}->{$loc}; + } + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + $code .= qq~ + +# Copying $name to $path directory. + \$file = \$tar->get_file('$name'); + \$file->name("$path/$name"); + \$file->write or return $plugin_pkg->error("Unable to extract file '$path/$name': \$GT::Tar::error", 'WARN');~; + } + return $code; +} + +sub _create_uninstall_func { +# ------------------------------------------------------------------- +# Creates the uninstall function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + $code .= qq~\n \$mgr->uninstall_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~ \$mgr->uninstall_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + + $code .= qq~\n \$mgr->uninstall_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + return $code; +} + +sub _create_stubs { +# ------------------------------------------------------------------- +# Creates a subroutine stub for each hook. +# + my $self = shift; + my $code = ''; + if (@{$self->{plugin}->{hooks}}) { + $code .= qq~ + +# PLUGIN HOOKS +# =================================================================== +~; + } + my %seen; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $full_sub_name = $hook->[2]; + my ($sub_name) = $full_sub_name =~ /([^:]+)$/; + next if $seen{$sub_name}++; + my $hook_name = $hook->[0]; + $code .= qq~ + +sub $sub_name { +# ----------------------------------------------------------------------------- +# This subroutine will be called whenever the hook '$hook_name' is run. You +# should call @{[$self->{oo} || 'GT::Plugins']}->action(STOP) if you don't want the regular +# '$hook_name' code to run, otherwise the code will continue as normal. +# + my (\@args) = \@_; + +# Do something useful here + + return \@args; +}~; + } + if (@{$self->{plugin}->{menu}}) { + $code .= qq~ + +# ADMIN MENU OPTIONS +# =================================================================== +~; + } + %seen = (); + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; + my $val2 = $menu->[1]; + my ($func) = $val2 =~ /func=(\w+)/; + next if $seen{$func}++; + if ($func) { + $code .= qq~ +sub $func { +# ------------------------------------------------------------------- +# This subroutine will be called whenever the user clicks on '$val1' in the +# admin menu. Remember, you need to print your own HTTP header; to do so you +# can use: +# +# print \$IN->header(); +# + +}~; + } + } + return $code; +} + +sub _create_wizard { +# ------------------------------------------------------------------- +# Creates the Wizard.pm file which is used to load wizard information. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $author = $self->{plugin}->{meta}->{author} || ''; + my $version = $self->{plugin}->{meta}->{version} || ''; + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta}); + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$WIZARD/; + +END_OF_PLUGIN + $output .= GT::Dumper->dump(var => '$WIZARD', data => $self->{plugin}); + $output .= "\n\n1;\n"; + return $output; +} + +sub _load_tar { +# ------------------------------------------------------------------- +# Loads a tar file. +# + my $self = shift; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $self->{plugin}->{name} . ".tar"; + if (-e $file) { + $self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } + else { + $self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } +} + +sub _load_plugin { +# ------------------------------------------------------------------- +# Loads the meta information into self. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm') + or return $self->error('CANTLOAD', 'WARN', $self->{plugin}->{name}, "No Wizard.pm file found in tar!"); + +# Eval the install file. + my $file = $wizard->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $file, "Wizard.pm does not compile: $@"); + } + } + +# Load the information. + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + my $var = $plugin_pkg . "::WIZARD"; + { + no strict 'refs'; + $self->{plugin} = $$var; + } + + return 1; +} + +sub _list_editable { +# ------------------------------------------------------------------- +# Returns a select list of plugins that can be edited by the wizard. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + my $count = 0; + my $select = ""; + return $count ? $select : ''; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/RDF.pm b/site/slowtwitch.com/cgi-bin/articles/GT/RDF.pm new file mode 100644 index 0000000..754230e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/RDF.pm @@ -0,0 +1,155 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::RDF +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $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).*?]*?>),$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; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL.pm new file mode 100644 index 0000000..44aaa69 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL.pm @@ -0,0 +1,716 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL +# CVS Info : 087,071,086,086,085 +# $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt 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.112 $ =~ /(\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'", + FKMISSING => "The '%s' table has a relationship with the '%s' table, but the foreign key information from the '%s' table is missing.", + 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.112 $ +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 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 0> or C 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 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 + + $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. 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. + +=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 name. + +=item PREFIX + +This specifies a prefix to use for table names. See the L +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 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 is the name of the table you wish to create. See +L 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 is the name of the table you wish the modify. See +L 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 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 to the beginning of every +table name. This means anywhere you access the table C, the actual table +stored on the SQL server will be C. Note that the prefix should B +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 + +L + +L + +L + +L + +L + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Admin.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Admin.pm new file mode 100644 index 0000000..8af50f9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Admin.pm @@ -0,0 +1,2994 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Admin +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Admin.pm,v 1.161 2009/05/11 22:57:15 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Used to create a basic admin area for the most common admin +# setup. For anything more complex use the Display modules +# individually. This also proves an excelent example of +# how to use the HTML module. +# + +package GT::SQL::Admin; +# =================================================================== +use strict; +use GT::Base; +use GT::AutoLoader; +use GT::CGI; +use GT::SQL; +use GT::SQL::Display::HTML; + +use vars qw/ + @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS + $BAR_COLOR $BAR_FONT $TITLE_FONT $FONT $BODY + $ROW_COLOR1 $ROW_COLOR2 %ACTION +/; + +# Possible arguments to new +$ATTRIBS = { + header => undef, + footer => undef, + start_form => undef, + end_form => undef, + start_html => undef, + end_html => undef, + record => undef +}; + +# Error messages are stored in GT::SQL. +@ISA = qw/GT::Base/; +$ERROR_MESSAGE = 'GT::SQL'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.161 $ =~ /(\d+)\.(\d+)/; + +# Some default HTML attributes. +$BODY = 'bgcolor="#FFFFFF"'; +$BAR_COLOR = 'navy'; +$BAR_FONT = "face='Arial' size='2' color='#FFFFFF'"; +$TITLE_FONT = "face='Arial' size='2' color='#000000'"; +$FONT = "face='Tahoma,Arial,Helvetica' size='2' color='#000000'"; +$ROW_COLOR1 = 'bgcolor="#dddddd"'; +$ROW_COLOR2 = 'bgcolor="#eeeeee"'; + +%ACTION = ( + add_form => 1, + add_record => 1, + add_success => 1, + delete_records => 1, + delete_results => 1, + delete_search_form => 1, + delete_search_results => 1, + download_file => 1, + edit_table_def => 1, + editor_add_field => 1, + editor_add_field_form => 1, + editor_column_checks => 1, + editor_column_form => 1, + editor_column_help => 1, + editor_columns => 1, + editor_delete_field => 1, + editor_delete_field_form => 1, + editor_export_data => 1, + editor_export_data_form => 1, + editor_import_data => 1, + editor_import_data_form => 1, + editor_modify_columns => 1, + editor_table_form => 1, + editor_update_def => 1, + modify_error => 1, + modify_form => 1, + modify_multi_records => 1, + modify_multi_results => 1, + modify_multi_search_results => 1, + modify_record => 1, + modify_search_form => 1, + modify_search_results => 1, + modify_success => 1, + search_form => 1, + search_results => 1, + view_file => 1 +); + +# ================================================================================ # +# SIMPLE INTERFACE # +# ================================================================================ # + +## +# $obj->process($defs, $in); +# -------------------- +# $defs must be the full path to the directory +# the definition file GT::SQL created. +# $in is a cgi object. This will process +# the cgi object from the forms it created. +# The proper changes will then be made and the +# results shown to the user. +# You should call this after testing to see if +# the input from the cgi is for_me. +## +sub process { + my $self = shift; + $self->initialize(@_) or return; + +# Find out what we are doing. + my $action = $self->{cgi}->{do}; + if (exists $ACTION{$action}) { + $self->$action(); +# print "

        QUERY STACK: ", GT::SQL->query_stack_disp, "
        "; # if ($self->{_debug}); + } + else { +# ERROR they should have called for_me to see if there was an action for me :) + return $self->error('NOACTION', 'FATAL', $action); + } +} + +sub initialize { + my ($self, @in) = @_; + +# Find out what we have, and store the CGI values in self->{cgi}. + my $opt = $self->common_param(@in) or return $self->error("BADARGS", 'FATAL', '$obj->process($in) where $in is a CGI object'); + $self->{in} = $opt->{cgi}; + $self->{cgi} = $self->common_param($opt->{cgi}) or return $self->error("BADARGS", 'FATAL', "You must pass in a cgi object"); + + my $tbl_names = ($self->{cgi}->{db}) || ($opt->{tables}) || (return $self->error('BADARGS', 'FATAL', 'No table passed in via CGI or tables method')); + ref($tbl_names) || ($tbl_names = [ $tbl_names ]); + + if ($opt->{def_path}) { + return $self->error(BADARGS => FATAL => "The 'def_path' argument to \$admin->process is deprecated. You should pass in a GT::SQL object using 'db' instead."); + } + $self->{db} = $opt->{db} or return $self->error('BADARGS', 'FATAL', 'Error: You must pass in a GT::SQL object.'); + $self->{table} = $self->{db}->table(@$tbl_names) or return; + +# Get the name of this table. + my $prefix = $self->{db}->prefix; + if (length $prefix) { + $self->{record} ||= join(',', map { s/^$prefix//; $_; } $self->{table}->name); + } + else { + $self->{record} ||= join(',', $self->{table}->name); + } + +# Get the Display object. + if ($opt->{display}) { + $self->{html} = $opt->{display}; + } + else { + $self->{html} = $self->{db}->html($self->{table}, $self->{cgi}); + } + $self->{html}->{url} = GT::CGI->url(remove_empty => 1); + +# Set any attributes the user passed in to process. + foreach my $option (keys %{$ATTRIBS}) { + $self->{$option} = $opt->{$option} if (exists $opt->{$option}); + } + return 1; +} + +sub preserve { + my $self = shift; + if (@_) { + my $preserve = shift; + $self->{preserve} = $preserve; + } + return $self->{preserve}; +} + +## +# GT::SQL::Admin->for_me($in); +# ---------------------------- +# $in is a cgi object. You should call this in +# an if to see if the cgi object is from a form +# this module produced. +## +sub for_me { + my ($self, @in) = @_; + +# Get options + my $opt = $self->common_param(@in) or return $self->error("BADARGS", 'FATAL', 'GT::SQL::Admin->for_me($in) where $in is a CGI object'); + +# There is no action so return false + $opt->{do} or return 0; + $opt->{db} or return 0; + +# Check to see if there is a routine in this module. + return exists $ACTION{$opt->{do}}; +} + +# Make sure AUTOLOAD does not catch destroyed objects. +sub DESTROY {} + +# ================================================================================ # +# FILE HANDLING # +# ================================================================================ # + +$COMPILE{download_file} = __LINE__ . <<'END_OF_SUB'; +sub download_file { + my ($self, $inline) = @_; + my $in = $self->{in}; + + my $table_name = $in->param('db'); + my $id = $in->param('id'); + my $cn = $in->param('cn'); + my $src = $in->param('src') || 'db'; + my $fname = $in->param('fname'); + + unless ($table_name and $id and $cn) { + print $in->header(); + print $self->_start_html({ title => 'Error Downloading' }); + print $self->_header("Unknown Document Reference", $@); + print $self->_end_html; + return; + } + + my $tbl = $self->{table}; + my ($fh, $size, $mimetype); + if ($src eq 'db') { + eval { $fh = $tbl->file_info($cn, $id) }; + if ($fh) { + $fname = $fh->File_Name(); + $mimetype = $fh->File_MimeType(); + $size = $fh->File_Size(); + } + } + else { + require GT::SQL::File; + eval { $fh = GT::SQL::File->open($fname) }; + $size = -s $fname; + $fname = GT::SQL::File->get_filename($fname); + } + + if (!$fh) { + print $in->header(); + print $self->_start_html({ title => 'Error Downloading' }); + print $self->_header("Error Downloading File", $@ || "Cannot find file pointed to by ID: $id and Column: $cn"); + print $self->_end_html; + } + else { + print $self->{in}->header( + $self->{in}->file_headers( + filename => $fname, + size => $size, + $inline ? () : (inline => 0) + ) + ); + + $fh->File_Binary() and binmode STDOUT; + + while (read($fh, my $buffer, 4096)) { + print $buffer; + } + } +} +END_OF_SUB + + +sub view_file { + my $self = shift; + $self->download_file(1); +} + + +# ================================================================================ # +# SEARCHING RECORDS # +# ================================================================================ # + +$COMPILE{search_form} = __LINE__ . <<'END_OF_SUB'; +sub search_form { + my ($self, $msg) = @_; + $msg &&= qq|$msg|; + + print $self->{in}->header; + print $self->_start_html({ title => "Search Form" }); + print $self->_header("Search Form", $msg || "Search the database to view records."); + print $self->_start_form({ do => "search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'search_form', search_opts => 1, file_browse => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->search_results; +# --------------------- +# Produces the search results for the user to view. +## +$COMPILE{search_results} = __LINE__ . <<'END_OF_SUB'; +sub search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->search_form("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}); + my $hits = $self->{table}->hits(); + if ($hits == 0) { + return $self->search_form("Your search did not match any records."); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + my $name = GT::CGI->url(remove_empty => 1); + if ($hits > ($self->{cgi}->{mh} || 25)) { + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + + if ($self->{in}->param('dr') and $self->{in}->param('dr') eq 'rows') { + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + my $i = 0; + while (my $result = $sth->fetchrow_hashref) { + print "", $self->{html}->display_row({ mode => 'search_results', values => $result }), ""; + } + print "
        "; + } + + else { + while (my $result = $sth->fetchrow_hashref) { + print "

        ", $self->{html}->display({ mode => 'search_results', values => $result }); + } + } + + print $speedbar if ($speedbar); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# ADD RECORDS # +# ================================================================================ # + +## +# $obj->add_form; +# --------------- +# This will print the add form for the current +# tables that we are working with. All the +# options that were set in settings will apply +# to the html that is printed here. +## +$COMPILE{add_form} = __LINE__ . <<'END_OF_SUB'; +sub add_form { + my ($self, $msg) = @_; + print $self->{in}->header; + my $hk = [$self->{table}->ai]; + $msg &&= qq|$msg|; + print $self->_start_html({ title => $msg ? "Add Record Failed" : "Add Record" }); + print $self->_header($msg ? "Add Record Failed" : "Add Record", $msg || "Add a record to the database"); + print $self->_start_form({ do => "add_record", db => $self->{cgi}->{db} }); + print $self->{html}->form({ mode => 'add_form', defaults => 1, hide => $hk, hide_timestamp => 1, search_opts => 0, file_field => 1 }); + print "

        ", $self->_buttons("Add"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + + return 1; +} +END_OF_SUB + +## +# $obj->add_record; +# ----------------------- +# This will add the record to the database and +# return the record ID on success undef on failure. +## +$COMPILE{add_record} = __LINE__ . <<'END_OF_SUB'; +sub add_record { + my $self = shift; + +# Turn arrays into delimited fields + $self->format_insert_cgi; + + if (defined(my $ret = $self->{table}->add($self->{cgi}))) { + $self->add_success($ret); + } + else { + local $^W; + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + + $self->add_form("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->add_success; +# ------------------ +# This will print the success page after adding a +# record. +## +$COMPILE{add_success} = __LINE__ . <<'END_OF_SUB'; +sub add_success { + my ($self, $id) = @_; + print $self->{in}->header; + + my $hsh; + if ($self->{table}->ai) { + $hsh = $self->{table}->get($id, 'HASH'); + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{$_}; } + $hsh = $self->{table}->get($lookup, 'HASH'); + } + + print $self->_start_html({ title => "Record Added" }); + print $self->_header("Record Added", "The following record was successfully added:"); + print "

        "; + print $self->{html}->display({ mode => 'add_success', values => $hsh }); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# DELETE RECORDS # +# ================================================================================ # + +## +# $obj->delete_search_form; +# ------------------------- +# Produces the search form to search to delete records. +# +# $obj->delete_search_form($message); +# ------------------------------------ +# Same thing as above but puts the message at the top in +# red and bold. Great for errors or not search results. +## +$COMPILE{delete_search_form} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html({ title => "Delete Records" }); + print $self->_header("Delete Records", $msg || "Search to delete records."); + print $self->_start_form({ do => "delete_search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'delete_search_form', search_opts => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_search_results; +# ---------------------------- +# Performs the search and returns the result forms +# to delete records. +## +$COMPILE{delete_search_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->delete_search_form("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->delete_search_form("Your search returned no results."); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_start_form({ do => 'delete_records', db => $self->{cgi}->{db} }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + + my @pk; + +# If we have a relation + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ($self->{in}->param('dr') and $self->{in}->param('dr') eq 'rows') { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row({ mode => 'search_results', values => $result }), ""; + print qq~~; + $i++; + } + + print "
        Delete
        \n"; + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display({ mode => 'delete_search_results', values => $result }); + print "
        \n"; + $i++; + } + + } + + + print $speedbar if ($speedbar); + print < 2; # Only print the Check All box if there is more than one thing to check + +

        Check All

        +END_OF_HTML + print "

        ", $self->_buttons("Delete"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_records; +# --------------------- +# Performs the delete and returns the success page. +## +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { + my $self = shift; + +# Make sure we have something to delete. + $self->{cgi}->{delete} or return $self->delete_results(0); + +# If they selected only one record to delete we still need an array ref + ref $self->{cgi}->{delete} eq 'ARRAY' or $self->{cgi}->{delete} = [$self->{cgi}->{delete}]; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{delete}}) { + my $change = {}; + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + next unless (keys %$change); + my $ret = $self->{table}->delete($change); + if (defined $ret and ($ret != 0)) { + $rec_modified++; + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return $self->delete_results($rec_modified); +} +END_OF_SUB + +$COMPILE{delete_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_results { + my ($self, $num_modified) = @_; + print $self->{in}->header; + + print $self->_start_html({ title => "Records Deleted" }); + print $self->_header("Records Deleted", "$num_modified record(s) were deleted."); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY RECORDS # +# ================================================================================ # + +## +# $obj->modify_search_form; +# ------------------------- +# Returns the html form to search to modify a +# record. +# +# $obj->modify_search_form($message); +# ---------------------------------- +# The same thing just puts the message at the top of the +# field. Great for errors. +## +$COMPILE{modify_search_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html({ title => "Modify Record" }); + print $self->_header("Modify Record", $msg || "Search to modify a record."); + print $self->_start_form({ do => "modify_search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'modify_search_form', search_opts => 1 }); + print "

        ", $self->_search_options({ modify_mult => 1 }); + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_search_results; +# ---------------------------- +# Returns the form that displays the results of a +# search to modify a record. +## +$COMPILE{modify_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_results { + my $self = shift; + print $self->{in}->header; + +# If they are modifying multiple records. + if ($self->{cgi}->{modify_multi_form}) { + return $self->modify_multi_search_results(@_); + } + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_start_form({ do => 'modify_form', db => $self->{cgi}->{db} }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ($self->{in}->param('dr') eq 'rows') { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row({ mode => 'modify_search_results', values => $result }); + print "\n"; + $i++; + } + + print "
        Modify
        \n"; + + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display({ mode => 'modify_search_results', values => $result }); + print "
        \n"; + $i++; + } + + }; + + + print $speedbar if ($speedbar); + print "

        ", $self->_buttons("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_form($message); +# ------------------ +# Returns the form to modify a single record. +# $message is optional. It will be at the top of the form. +## +$COMPILE{modify_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + my $values; + my $mod = $self->{cgi}->{modify}; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error("Please select a record to modify before continuing."); + } + if ($self->{cgi}->{modify} == 0) { + $values = $self->{cgi}; + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{"$mod-$_"}; } + $values = $self->{table}->get($lookup, 'HASH'); + } + print $self->_start_html({ title => "Modify Record" }); + print $self->_header("Modify Record", $msg || "Modify a record."); + print $self->_start_form({ do => "modify_record", db => $self->{cgi}->{db} }); + print $self->{html}->form({ mode => 'modify_form', values => $values, view_key => 1, file_field => 1, file_delete => 1 }); + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + print qq( +

        +
        + + ); + print $self->_start_form({ do => "delete_records", db => $self->{cgi}->{db} }, { name => 'admin_delete' }); + print qq(
        ); + for (@pk) { + print qq(); + } + print qq( + + + ); + print qq( +
        +
        + ); + print $self->_end_form; + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_record; +# -------------------- +# Makes the modifications to the record. Returns the +# failure page on error (which is the modify form with a message) +# and the success page on success. +## +$COMPILE{modify_record} = __LINE__ . <<'END_OF_SUB'; +sub modify_record { + my $self = shift; + +# Format arrays for insertion + $self->format_insert_cgi; + + if ($self->{table}->modify($self->{cgi})) { + return $self->modify_success; + } + else { + $self->{cgi}->{modify} = 0; + if ($GT::SQL::errcode eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{$_}; + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if ($rec) { + foreach (keys %$rec) { + $self->{cgi}->{$_} = $rec->{$_}; + } + return $self->modify_form("The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit."); + } + else { + return $self->modify_error("The record you attempted to modify could not be found."); + } + } + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + return $self->modify_form("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->modify_success; +# --------------------- +# Returns the success form after someone modifies +# a record. +## +$COMPILE{modify_success} = __LINE__ . <<'END_OF_SUB'; +sub modify_success { + my $self = shift; + print $self->{in}->header; + my $lookup = {}; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + foreach (@pk) { + $lookup->{$_} = $self->{cgi}->{$_} if (exists $self->{cgi}->{$_}); + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if (! $rec) { + return $self->modify_error("The record you attempted to modify could not be found."); + } + + print $self->_start_html({ title => "Record Modified" }); + print $self->_header("Record Modified", "The following record was successfully updated:"); + print "

        "; + + print $self->{html}->display({ mode => 'modify_success', values => $rec }); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_error; +# --------------------- +# Modify error which doesn't/can't display the record. +## +$COMPILE{modify_error} = __LINE__ . <<'END_OF_SUB'; +sub modify_error { + my $self = shift; + my $msg = shift; + print $self->{in}->header; + + print $self->_start_html({ title => "Modify Error" }); + print $self->_header("Modify Error", $msg); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY MULTIPLE RECORDS # +# ================================================================================ # + +## +# $obj->modify_multi_search_results; +# ------------------------ +# Returns the forms to modify records. +## +$COMPILE{modify_multi_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_search_results { + + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html({ title => "Modify Search Results" }); + print $self->_start_form({ do => 'modify_multi_records', db => $self->{cgi}->{db} }); + print $self->_header("Modify Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + while (my $result = $sth->fetchrow_hashref) { + print qq~

        ~; + print $self->{html}->form({ mode => 'modify_multi_search_results', values => $result, multiple => $i, view_key => 1, file_field => 1, file_delete => 1 }); + print "
        \n"; + $i++; + } + print $speedbar if ($speedbar); + print "

        ", $self->_buttons("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_multi_records; +# --------------------------- +# This performs the modify on the multiple records. This returns +# the success page on error and the modify form on failure. It should +# call the modify form in a way that it can reproduce the records that +# were not successfully modified. See the comments above to see how +# modify_multi_form is called. +## +$COMPILE{modify_multi_records} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_records { + my $self = shift; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error("Please select a record to modify before continuing."); + } +# If they selected only one record to modify we still need an array ref + ref $self->{cgi}->{modify} eq 'ARRAY' or $self->{cgi}->{modify} = [$self->{cgi}->{modify}]; + +# Format the cgi for inserting + $self->format_insert_cgi; + +# Hash to handle errors if there are any errors. + my $errors = {}; + my $errcode = {}; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{modify}}) { + +# The hash ref, we need, to modify a record. + my $change = {}; + +# For through the column names to build our modification hash + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + +# Make the changes and capture any errors. + my $ret = $self->{table}->modify($change); + if (defined $ret) { + $rec_modified++; + } + else { + if ($GT::SQL::error){ + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + $errors->{$rec_num} = "
      • $error"; + } + $errcode->{$rec_num} = $GT::SQL::errcode if ($GT::SQL::errcode); + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return (keys %{$errors}) ? $self->modify_multi_results($rec_modified, $errors, $errcode) : $self->modify_multi_results($rec_modified); +} +END_OF_SUB + +## +# $obj->modify_multi_results($num_modified); +# ------------------------------------------- +# This will return the results page after the user modifies +# the record from the modify_multi_form. $num_modified is the +# number of records that were modified. +# +# $obj->modify_multi_results($num_modified, \%not_modified, \%error_codes); +# ----------------------------------------------------------- +# This is how you handle errors. The first argument is the number +# of records that were modified. The second is a hash ref of primary +# keys to reasons the message was not modified. If there is more than +# one column that makes up the primary key they should be flatened +# to a comma separated list of keys in the proper order. +## +$COMPILE{modify_multi_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_results { + my ($self, $num_modified, $errors, $errcodes) = @_; + my ($ok_out, $error_out) = ('', ''); + $errcodes ||= {}; + +# Lets get our error records if we messed up. + if ($errors) { + my @cond = (); + $error_out = $self->_header("Modify Failed", "The following record(s) were not modified successfully. Please correct the errors and submit again."); + $error_out .= $self->_start_form({ do => 'modify_multi_records', db => $self->{cgi}->{db} }); + + my $cols = $self->{table}->cols; + foreach my $rec (keys %$errors) { + my $values = {}; + if ($errcodes->{$rec} eq 'NORECMOD') { + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= qq~

        The record could not be found in the database~; + $error_out .= qq~
           ~; + $error_out .= $self->{html}->display({ mode => 'modify_multi_results_norec', values => $values }); + $error_out .= qq~
        \n~; + } + elsif ($errcodes->{$rec} eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{"$rec-$_"}; + } + my $result = $self->{table}->get($lookup, 'HASH'); + foreach (keys %$result) { + $values->{$_} = $result->{$_}; + } + $error_out .= qq~

        The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit.~; + $error_out .= qq~
        ~; + $error_out .= $self->{html}->form({ mode => 'modify_multi_result_changed', values => $values, multiple => $rec }); + $error_out .= qq~
        \n~; + } + else { + $error_out .= qq~

        $errors->{$rec}
        ~; + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= $self->{html}->form({ values => $values, multiple => $rec, mode => 'modify_multi_results_err' }); + $error_out .= qq~
        \n~; + } + } + $error_out .= "

        " . $self->_buttons("Modify"); + $error_out .= $self->_end_form; + } + +# If there were successfull modifications. + if ($num_modified) { + $ok_out = $self->_header("Modify Success", "$num_modified record(s) were successfully updated."); + $ok_out .= "

        "; + } + +# Print the HTML + print $self->{in}->header; + print $self->_start_html({ title => "Record Modified" }); + print $ok_out; + print $error_out; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{format_insert_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_insert_cgi { + my $self = shift; + my $cols = $self->{table}->cols; + foreach (keys % $cols) { + if (! exists $self->{cgi}->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX') { + $self->{cgi}->{$_} = ''; + } + } +} +END_OF_SUB + +$COMPILE{format_search_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_search_cgi { + my $self = shift; + foreach (keys %{$self->{table}->cols}) { + next unless (ref $self->{cgi}->{$_} eq 'ARRAY'); + if (exists $self->{cgi}->{"$_-opt"} and $self->{cgi}->{"$_-opt"} eq 'LIKE') { + $self->{cgi}->{$_} = join("$GT::SQL::Display::HTML::INPUT_SEPARATOR%", sort @{$self->{cgi}->{$_}}); + } + else { + $self->{cgi}->{$_} = join($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$self->{cgi}->{$_}}); + } + } +} +END_OF_SUB + +# ================================================================================ # +# EDIT TABLES # +# ================================================================================ # + +$COMPILE{editor_table_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_table_form { +# ------------------------------------------------------------------- +# $obj->editor_table_form; +# ------------------------ +# Prints the form to edit the table +# definitions. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + +# Update the table if required + $self->{in}->param('update_def') and $msg .= $self->edit_table_def || "Table Definition Update Successful"; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Table Maintenance: $table"); + print $self->_start_form({ do => 'editor_table_form', db => $self->{cgi}->{db}, update_def => 1 }); + my $url = GT::CGI->url({ query_string => 0 }); + + my $show_weight_h = (keys %{$self->{table}->weight}) ? "Index Weight" : ''; + if ($show_weight_h) { + $show_weight_h = qq~Search
        Weight
        ~; + } + else { + $show_weight_h = ''; + } + print qq~ +

        Edit $table Table Definition
        + Below is all the columns in your $table table. By clicking on one of the column names, you can view more details + as well as alter the column definition.

        +
        + + + + + + + + + + + $show_weight_h + + ~; + my %cols = %{$self->{table}->cols}; + foreach my $column ($self->{table}->ordered_columns) { + my %attribs = %{$cols{$column}}; + $attribs{pos} ||= ' '; + $attribs{type} ||= ' '; + $attribs{not_null} ||= ' '; + $attribs{default} = ' ' if not defined $attribs{default} or $attribs{default} eq ''; + $attribs{form_display} ||= ' '; + $attribs{form_type} ||= 'TEXT'; + $attribs{regex} ||= ' '; + + if ($show_weight_h) { + $attribs{weight} ||= ' '; + $show_weight_h = qq~~; + } + ($attribs{not_null} eq '1') ? ($attribs{not_null} = "Yes") : ($attribs{not_null} = "No"); + print qq~ + + + ~; + if ($attribs{protect}) { + print qq~~; + } + else { + print qq~~; + } + print qq~ + + + + + + + $show_weight_h + + ~; + } + print qq~ +
        PositionColumn
        Name
        Column
        Type
        Not
        Null
        DefaultForm
        Display
        Form
        Type
        Form
        Regex
        $attribs{weight}
        $attribs{pos}$column$column$attribs{type}~; + print "($attribs{size})" if ($attribs{size}); + print "(" . join (", " => @{$attribs{values}}) . ")" if ($attribs{values} and (ref $attribs{values})); + print qq~$attribs{not_null}$attribs{default}$attribs{form_display}$attribs{form_type}$attribs{regex}
        +
        + +
        + +
        + + + + + + + +
        Database Information
        Indexing Scheme + +
        +
        + +
        + +
        + + +
        +
        +
        + +
        + ~; + + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{edit_table_def} = __LINE__ . <<'END_OF_SUB'; +sub edit_table_def { +# ------------------------------------------------------------------- + my $self = shift; + my $in = $self->{in}; + +# handle the indexing scheme + my $e = $self->{db}->editor( $in->param('db') ); + $e->change_search_driver( $in->param('search_driver') ) or return $GT::SQL::error; + + return; +} +END_OF_SUB + +$COMPILE{editor_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_columns { +# ------------------------------------------------------------------- +# Form to modify a selected column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + my $column = $self->{cgi}->{modify}; + my %cols = $self->{table}->cols; + my %attribs = %{$cols{$column}}; + my $url = GT::CGI->url({ query_string => 0 }); + exists $cols{$column} or return $self->editor_table_form("Column ($column) does not exist in table" . $self->{table}->name); + +# Print the intro. + print $self->_start_html({ title => "Edit $column Column Definition" }); + print $self->_header("Table Editor", $msg || "Edit $column Column Definition"); + print $self->_start_form({ do => 'editor_modify_columns', db => $self->{cgi}->{db}, modify => $column }); + print qq~ +

        For information on what each column means, click here.

        + ~; + +# Set up defaults for the fields + foreach my $col (qw/column type not_null file_save_in file_save_url file_max_size file_save_scheme default form_display form_type form_size form_names form_values regex weight values size/) { + $attribs{$col} = $self->{cgi}->{$col} if (defined $self->{cgi}->{$col}); + } + $attribs{column} ||= $column; + $attribs{form_type} ||= 'TEXT'; + $attribs{form_size} ||= ($attribs{form_type} eq 'SELECT') ? 0 : ''; + ref $attribs{form_size} and ($attribs{form_size} = join (",", @{$attribs{form_size}})); + ref $attribs{form_names} and ($attribs{form_names} = join ("\n", @{$attribs{form_names}})); + ref $attribs{form_values} and ($attribs{form_values} = join ("\n", @{$attribs{form_values}})); + ref $attribs{values} and ($attribs{values} = join ("\n", @{$attribs{values}})); + +# Display the form. + my $index_list = $self->_index_list($column); + print $self->editor_column_form(\%attribs, $index_list, 'modify'); + + print $self->_buttons("Update Table"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{editor_modify_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_modify_columns { +# -------------------------------------------------------- +# Modifies a column definition. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $column = $self->{cgi}->{modify} || return $self->editor_columns("You must enter a column name."); + foreach my $def (qw/column type not_null default form_display form_type form_size file_save_in file_save_url file_max_size file_save_scheme regex weight size/) { + $attribs{$def} = $self->{cgi}->{$def} if (defined $self->{cgi}->{$def}); + } + $attribs{form_type} ||= 'TEXT'; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + +# Keep any values that where there before + my $old_def = $self->{table}->cols->{$column}; + for my $val (keys %$old_def) { + $attribs{$val} = $old_def->{$val} unless exists $attribs{$val}; + } + +# Error checking + my $errors = $self->editor_column_checks($column, \%attribs, 'modify'); + if ($self->{cgi}->{index} eq 'primary' and ($column ne $self->{table}->{schema}->{pk})) { + $errors .= "

      • This table already has a primary key."; + } + $errors and return $self->editor_columns("
          $errors
        "); + +# Add/Drop indexes. + my $index_type = $self->_index_type($column); + my @post_change; + if ($index_type ne $self->{cgi}->{index}) { + if ($index_type eq 'none') { + # Adding an index - delay this until _after_ the column has been changed + if ($self->{cgi}->{index} eq 'regular') { + push @post_change, [add_index => "${column}_idx" => [$column]]; + } + else { + push @post_change, [add_unique => "${column}_idx" => [$column]]; + } + } + elsif ($self->{cgi}->{index} eq 'none') { + # Dropping an index + if ($index_type eq 'regular') { + my $index = $self->{table}->index; + INDEX: foreach my $index_name (keys %$index) { + foreach my $col_name (@{$index->{$index_name}}) { + next unless ($col_name eq $column); + $editor->drop_index($index_name) or return $self->editor_columns($GT::SQL::error); + last INDEX; + } + } + } + else { + my $unique = $self->{table}->unique; + INDEX: foreach my $unique_name (keys %$unique) { + foreach my $col_name (@{$unique->{$unique_name}}) { + next unless ($col_name eq $column); + $editor->drop_unique($unique_name) or return $self->editor_columns($GT::SQL::error); + last INDEX; + } + } + } + } + } + +# Make the changes + delete $attribs{column}; + $editor->alter_col($column, \%attribs) or return $self->editor_columns($editor->error); + + for (@post_change) { + my ($meth, @args) = @$_; + $editor->$meth(@args); + } + + return $self->editor_table_form("$column has been updated!"); +} +END_OF_SUB + +$COMPILE{editor_column_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_form { +# ------------------------------------------------------------------- +# Displays an Add/Modify column form. +# + my ($self, $attribs, $index_list, $mode) = @_; + + my $output = qq~ +
        + ~; + + if ($mode eq 'add') { + $output .= qq~ + + + ~; + } + + else { + $output .= qq~ + + + + ~; + }; + + my $match = 0; + my @types = qw/INT TINYINT SMALLINT MEDIUMINT BIGINT FLOAT DOUBLE CHAR VARCHAR TEXT DATE DATETIME ENUM/; + for (@types) { + if ($attribs->{type} eq $_) { + $match = 1; + last; + } + } + my $extra = ''; + if (! $match) { + $extra = " + + + + + + + + + + + + + + + + + + ~; + +# Only display Search Weight form if this table has a search weight set. + if (keys %{$self->{table}->weight}) { + $output .= qq~~; + } + + $output .= qq~ +
        Database Information
        Column Name
        Database Information
        WARNING: If you change a field's type, data in that field may be lost. Also, if you alter one of the system fields, it may render your system inoperable.
        Column Name$attribs->{column}
        Column Type +
        Column Index$index_list
        Column Size
        (Only for CHAR types)
        Column Values
        (Only for ENUM types)
        Not Null + + Yes{not_null}); $output .= qq~> + No{not_null}); $output .= qq~> +
        Default
        Form Information
        Form Display
        Form Type +
        Form Size
        Form Names
        (Stored in Database)
        Only for checkbox, multi-select or radio forms.
        Form Values
        (Displayed on Form)
        Only for checkbox, multi-select or radio forms.
        File Save Location
        (Only for FILE types. Stored on disk)
        File Save URL
        (Only for FILE types)
        File Save Method
        (Only for FILE types)
        +
        File Maximum Size
        (Only for FILE types.)
        Form Regex
        Search Weight
        +
        +
        + ~; + return $output; +} +END_OF_SUB + +$COMPILE{editor_column_checks} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_checks { +# ------------------------------------------------------------------- +# Check to make sure a column add/change is valid. +# + my ($self, $column, $attribs) = @_; + my $errors = ''; + +# Remove attributes that don't make sense. + $attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR' or delete $attribs->{size}; + $attribs->{type} eq 'ENUM' or delete $attribs->{values}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_names}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_values}; + $attribs->{form_type} =~ /^(?:CHECKBOX|RADIO)$/ and delete $attribs->{form_size}; + $attribs->{default} =~ /^\s*$/ and delete $attribs->{default}; + +# Go through and weed out problem cases. + if ($column !~ /^(\w+)$/) { + $errors .= "
      • Column name '$column' is invalid. The column name can only contain letters, numbers and an underscore."; + } + if ($column =~ /^[\d_]/) { + $errors .= "
      • Column name '$column' is invalid. Column names can not start with a number or an underscore."; + } + if (($attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR') and ($attribs->{size} > 255 or $attribs->{size} < 1)) { + $errors .= "
      • Size '$attribs->{size}' is invalid. It must be between 1 and 255."; + } + if ($attribs->{type} eq 'ENUM') { + unless (ref $attribs->{values} eq 'ARRAY' and @{$attribs->{values}} >= 1) { + $errors .= "
      • You must specify the ENUM values in the 'Column Value' text area. Enter the value one perl line.
      • \n"; + } + if ($attribs->{default}) { + my $ok; + for my $value (@{$attribs->{values}}) { + $ok = 1, last if $value eq $attribs->{default}; + } + unless ($ok) { + $errors .= "
      • Your default must match one of the listed ENUM values."; + } + } + } + if ($attribs->{type} =~ /INT$/) { + if ($attribs->{default} and $attribs->{default} =~ /\D/) { + $errors .= "
      • The default value for INT columns cannot contain non-integral values.
      • "; + } + } + if ($attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/) { + if (! (@{$attribs->{form_names}} or @{$attribs->{form_values}}) ) { + $errors .= "
      • For radio, checkbox and select forms, you must specify the names and the values in the two textarea boxes one per line. The names are what is stored in the database, and the values is what is displayed in the browser."; + } + else { + if (@{$attribs->{form_names}} ne @{$attribs->{form_values}}) { + $errors .= "
      • Make sure you have the same number of lines for Form Names as you do for Form Values."; + } + } + } + if ($attribs->{form_type} eq 'TEXTAREA') { + if ($attribs->{form_size} =~ /^\s*(\d+)\s*,\s*(\d+)\s*$/) { + $attribs->{form_size} = [$1, $2]; + } + elsif ($attribs->{form_size} =~ /^\s*(\d+)\s*$/) { + $attribs->{form_size} = $1; + } + else { + $errors .= "
      • For TEXTAREA forms, please specify the size of the textarea as COLS,ROWS. For example, to have a 50 column, by 6 rows textarea box, you would enter 50,6 in the Form Size box."; + } + } + if ($attribs->{form_type} eq 'FILE') { + if ( $attribs->{file_save_in}) { + ( -e $attribs->{file_save_in} and -w $attribs->{file_save_in}) or + $errors .= "
      • File Save Location does not exist or is not writeable."; + } + else { + $errors .= "
      • File Save Location must be set."; + } + if ($attribs->{type} ne 'CHAR' and $attribs->{type} ne 'VARCHAR') { + $errors .= "
      • Database column must be of CHAR or VARCHAR."; + } + } + if (($attribs->{not_null} == 0) and ($self->{cgi}->{index} ne 'none')) { + $errors .= "
      • A column must be defined as not null if you want to index it."; + } + if (($self->{cgi}->{index} ne 'none') and ($attribs->{type} eq 'TEXT')) { + $errors .= "
      • You can not have an index on TEXT columns."; + } + if ($attribs->{weight} and $attribs->{weight} !~ /^\d+$/) { + $errors .= "
      • Search weight can only contain digits.
      • "; + } + return $errors; +} +END_OF_SUB + +$COMPILE{editor_add_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field_form { +# ------------------------------------------------------------------- +# Displays a form to add a new column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + +# Set up defaults for the fields + my %attribs = (); + foreach my $def (qw/ + column type not_null default form_display form_type form_size regex weight + size form_names form_values values file_save_in file_save_scheme + file_save_url file_max_size + /) { + $attribs{$def} = defined $self->{cgi}->{$def} ? $self->{cgi}->{$def} : ''; + } + $attribs{form_type} ||= 'TEXT'; + my $url = GT::CGI->url({ query_string => 0 }); + + print $self->_header("Table Editor", $msg || "Add a New Field to $table"); + print $self->_start_form({ do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +

        For information on what each column means, click here.

        + ~; + my $index_list = $self->_index_list(); + print $self->editor_column_form(\%attribs, $index_list, 'add'); + + print $self->_buttons("Add Field to"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_add_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field { +# ------------------------------------------------------------------- +# Add a new column to the database. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $table = $self->{cgi}->{db}; + my $column = $self->{cgi}->{column} || return $self->editor_add_field_form("You must enter a column name."); + my %cols = $self->{table}->cols; + $attribs{type} = $self->{cgi}->{type} || return $self->editor_add_field_form("You must enter a column type."); + $attribs{size} = $self->{cgi}->{size}; + $attribs{form_display} = $self->{cgi}->{form_display} || $self->{cgi}->{column}; + $attribs{not_null} = $self->{cgi}->{not_null} || 0; + $attribs{default} = $self->{cgi}->{default}; + $attribs{form_type} = $self->{cgi}->{form_type} || 'TEXT'; + $attribs{form_size} = $self->{cgi}->{form_size} || ''; + $attribs{regex} = $self->{cgi}->{regex} || ''; + $attribs{weight} = $self->{cgi}->{weight} || ''; + $attribs{file_save_in} = $self->{cgi}->{file_save_in} || ''; + $attribs{file_save_url} = $self->{cgi}->{file_save_url} || ''; + $attribs{file_max_size} = $self->{cgi}->{file_max_size} || ''; + $attribs{file_save_scheme} = $self->{cgi}->{file_save_scheme} || ''; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + $attribs{pos} = keys(%cols) + 1; + +# Error checking + my $errors = $self->editor_column_checks($column, \%attribs, 'add'); + if (exists $cols{$column}) { + $errors .= "

      • Column '$column' already exists, please choose another name."; + } + if ($self->{cgi}->{index} eq 'primary') { + $errors .= "
      • You can not add a primary key to an existing table."; + } + $errors and return $self->editor_add_field_form("
          $errors
        "); + +# Add the column. + delete $attribs{column}; + $editor->add_col($column, \%attribs) or return $self->editor_add_field_form("Unable to add column '$column': $GT::SQL::error"); + + my $field_form_message = "The column '$column' was added successfully, however an error occurred while "; + $self->{cgi}->{modify} = $column; +# Add the indexes. + if ($self->{cgi}->{index} eq 'regular') { + $editor->add_index($column . '_idx' => [$column]) or return $self->editor_columns("$field_form_message adding the index: $GT::SQL::error"); + } + elsif ($self->{cgi}->{index} eq 'unique') { + $editor->add_unique($column . '_udx' => [$column]) or return $self->editor_columns("$field_form_message adding the unique index: $GT::SQL::error"); + } + $self->{table}->reload; + + return $self->editor_table_form("The database has been succesfully updated."); +} +END_OF_SUB + +$COMPILE{editor_delete_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field_form { +# ------------------------------------------------------------------- +# Displays a form to delete a column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Delete a Field from $table."); + print $self->_start_form({ do => 'editor_delete_field', db => $self->{cgi}->{db} }); + + print qq~ +
        +
        +

        WARNING: If you remove a field, all data in that field will be lost. Also, if you remove + one of the system fields, certain functions may not work any more!

        ~; + my @cols = grep !exists $self->{table}->{schema}->{cols}->{$_}->{protect}, $self->{table}->ordered_columns; + if (@cols) { + print qq~ + Delete the following field: + +

        + ~; + } + else { + print qq<

        No columns can be deleted.

        >; + } + print qq~ +
        +
        +
        + ~; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_delete_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field { +# ------------------------------------------------------------------- +# Remove a field from the table. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my $table = $self->{cgi}->{db}; + my $field = $self->{cgi}->{'delete-field'} || return $self->editor_delete_field_form("Please select a field to delete!"); + ($field eq 'ID') and return $self->editor_delete_field_form("You can't remove the ID field."); + +# Drop the column from the database. + $editor->drop_col($field) or return $self->editor_delete_field_form($GT::SQL::error); + + return $self->editor_delete_field_form("The database has been successfully updated."); +} +END_OF_SUB + +$COMPILE{editor_update_def} = __LINE__ . <<'END_OF_SUB'; +sub editor_update_def { +# ------------------------------------------------------------------- +# Re-sync the def file with what's in the database. +# + my $self = shift; + +# We need a creator for this. + my $c = $self->{db}->creator($self->{table}->name); + $c->load_table or return $self->editor_table_form("Could not update def files reason $GT::SQL::error"); + +# Re Load our table object. + $self->{table}->reload; + + return $self->editor_table_form("The .def file has been re-synced."); +} +END_OF_SUB + +$COMPILE{editor_column_help} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_help { +# -------------------------------------------------------- +# Displays a help page for the editor. +# + my ($self, $msg) = @_; + my $table = $self->{cgi}->{db}; + print $self->{in}->header; + print $self->_start_html; + print $self->_header("Table Editor", $msg || "Add/Edit Columns Help."); + print $self->_start_form({ do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +
        + +

        From here you can add a new column to your table $table. When creating your column, you should set the following options: +

          +
        • Column Name: This is the name of your column. It must be a valid SQL name, which is just letters, numbers and the underscore character. Also, + try to avoid reserved words like FROM, SELECT, WHERE, JOIN, etc. +
        • Column Type: This is the type of column you want to create. Your choices are: +
            +
          • INT: This stores integer numbers, i.e. 1, 2, 3. Whole numbers without decimal points between -2147483648 and 2147483647. +
          • TINYINT: This stores integers between -128 and 127. +
          • SMALLINT: This stores integers between -32768 and 32767. +
          • MEDIUMINT: This stores integers between -8388608 and 8388607. +
          • BIGINT: This stores integers between -9223372036854775808 and 9223372036854775807. +
          • FLOAT: This stores 32-bit floating point numbers. +
          • DOUBLE: This stores 64-bit floating point numbers. +
          • CHAR: This stores any string up to a maximum size of 255. If you set a CHAR, you must set the + maximum size in Column Size. +
          • VARCHAR: This is the same as a CHAR column type except in the way it is stored and retrieved + from the database. +
          • TEXT: This stores a (virtually) unlimited amount of text. Use this for storing very large + amounts of texts. +
          • DATE: This stores a date defaulting to yyyy-mm-dd format. +
          • ENUM: This stores an enumerated list. This is useful when you want a field that can be + one of several values. For example, you could create a Status column that can contain + the values: 'Not Registered', 'Registered', 'Moderator', 'SuperUser'. The entries in this + column must be one of the listed values. You specify what values you want using one line + per entry in the Column Values field. +
          +
        • Column Index: This determins what sort of index the SQL server should use to speed up queries. If you use + an index, you must set Not Null to Yes. +
        • Column Size: This is only useful for CHAR types. It stores the maximum size a field can be and should range + anywhere from 1 to 255. +
        • Column Values: This is only useful for ENUM types. It stores the list of possible values, one per line. +
        • Not Null: If you set this to Yes, then a value must be entered for this column. If you set this to No, then + when you add a record, this column can be left blank. +
        • Default: This is the default value that will be displayed when adding a record. +
        • Form Type: This is the type of form to use when adding or modifying a record. Your choices are: +
            +
          • Hidden: This column will be hidden on the add and modify forms. +
          • Select: A select list will be generated. For select lists, Form Size determines the size + of the select list (set to 0 for a single select list, higher for multiple select lists). You should + enter the values of the select list (what will be displayed to the user) in the Form Values textarea, and + the data of the select list (what will be stored in the database) in the Form Names textarea. +
          • Checkbox: This generates a set of checkboxes. You need to enter into Form Values a list of all + the checkbox values (what will be displayed to the user), and in Form Names, a list of what will be stored + in the database. The data is stored in the database joined on a new line. +
          • Radio: This generates a radio option list. You must enter into Form Names the value that will be stored in the database, + and in Form Values, the value that will be displayed. +
          • Text: This generates a simple text box. You can set the size of text box using Form Size. +
          • Textarea: This generates a textarea field. You can set the rows and columns to use in the Form Size by entering rows,cols + (for example: 30,4). +
          • Password: This generates a password box. You can set the size of password box using Form Size. +
          • File: This creates a standard file field. You must set the File Save Location and set the database type to CHAR. +
          +
        • Form Size: This is only useful for select, text or textarea form types. For selects, set this to 0 to be a single + select field, set it to a postive number to be a multi select field. For Text fields, set this to the size of the text box, for + textarea types, set this to rows,cols to specify the size. +
        • Form Names: This is only useful for Select, Checkbox or Radio types. This is what will be stored in the database. You + should enter one value per line. +
        • Form Values: This is only useful for Select, Checkbox or Radio types. This is what will be displayed to the user. You should + enter one value per line. + +
        • File Save Location: Specifies in which directory where the the files are saved. Once you have set this, please try not to + change the save path. If you must, do not move the existing files unless you are prepared to prepared to update your + "@{[$self->{table}->name()]}_Files" table to reflect the move. + +
        • File Save URL: If this directory is accessibly by URL, specjfiy the base url here. This will allow retrieval of the full URL + path to the file should you want to display the file for viewing or download. + +
        • File Save Method: Once this has been set, please do not change unless there are no files being handled by the system. + This option sets how the files are to be stored in the directory. If you expect many files to be uploaded, the system will + use a collection of different directories to store the files. This allows faster lookups for by the OS and experienced + users will be able to "symlink" some of the directories to other harddrives to distribute the load. + +
        • File Maximum Size: Caps the maximum number of bytes of files users can upload. + +
        • Form Regex: This is a perl regular expression that data must match before being inserted or updated. +
        • Search Weight: If this is set to a positive value, this field will be included in the search index. Note: you must + rebuild the search index after changing/adding a search weight. +
        +

        +
        +
        + ~; + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + return; +} +END_OF_SUB + +## +# $self->editor_import_data_form; +# ------------------------------- +# Prints the page to import data. +## +$COMPILE{editor_import_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + my $table = $self->{record}; + + + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Import Data to $table."); + print $self->_start_form({ do => 'editor_import_data', db => $self->{cgi}->{db} }, { name => 'ImportForm'}); + + +print qq~ + +~; + + print qq~ +
        +

        You can either import from a file or you can cut and paste the contents into a textarea box. If you + have a large number of records, you should really import from a file. If you use quick mode, the file must contain the same + number of fields as the current table, and in the same order. If you don't use quick mode, the first line of either the file + or the text box must be a list of column names!
        +   +

        + +
        +
        + Fields to Import
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        +
        + + ~; + + print qq| +
        +
        +
        +

        + Import data from file: or from textarea box:
        +
        + Use as delimiter. + Delete old data first +
          +

        + ~; + print $self->_buttons("Import Data into"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_import_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data { +# -------------------------------------------------------- +# Import data from textarea box or file. +# + my $self = shift; + my ($delim, $file, $text, $res, @header); + + $delim = $self->{cgi}->{'import-delim'} || return $self->editor_import_data_form("No import delimiter specified!"); + $file = $self->{cgi}->{'import-file'}; + $text = $self->{cgi}->{'import-text'}; + +# Make sure they have picked the fields to import + $self->{cgi}->{'ImportRight'} or return $self->editor_import_data_form("No fields selected to import"); + @header = reverse ((ref ($self->{cgi}->{'ImportRight'}) eq 'ARRAY') ? @{$self->{cgi}->{'ImportRight'}} : $self->{cgi}->{'ImportRight'}); + + my $todo = 0; + for (@header) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_import_data_form("No fields selected to import") } + +# Make sure there is some data to import + $file or $text or return $self->editor_import_data_form("You must enter at least a filename or data in the textarea box."); + $file and $text and return $self->editor_import_data_form("Please only enter either a filename or data in the textarea box, not both."); + $delim = "\t" if $delim eq '\t'; + +# Store the lines to import in @lines and the header in $header. + my ($good_cnt, $err_cnt, $line, $line_num, @lines, @data, $error, %record, $i); + if ($file) { + open (FILE, "<$file") or return $self->editor_import_data_form("Unable to open file '$file': $!"); + local $/; + @lines = split /[\r\n]+/, ; + close FILE; + } + else { + @lines = split /[\r\n]+/, $text; + } + +# Remove old data if requested. + my $table = $self->{cgi}->{db}; + if ($self->{cgi}->{'import-delete'}) { + $self->{table}->delete_all; + } + +# Do the import. + $good_cnt = $err_cnt = 0; + LINE: for my $line_num (0 .. $#lines) { + ($err_cnt > 10) and last LINE; + $line = $lines[$line_num]; + @data = split /\Q$delim\E/, $line, -1; + if ($#data != $#header) { + $error .= "

      • " . ($line_num+2) . ": Row count: " . ($#data+1) . + " does not match header count: (@data) (@header)" . ($#header+1) . "\n"; + $err_cnt++; + next LINE; + } + $i = 0; + %record = (); + for (@data) { + $data[$i] =~ s/``/$delim/g; + $data[$i] =~ s/~~/\n/g; + $record{$header[$i]} = $data[$i]; + $i++; + } + unless ($line_num){ # check the first line and ignore it if this is a header line + my @check_diff = grep $record{$_} ne $_ => @data; + (@check_diff) or next LINE; + } + if (!$self->{table}->add(\%record, 1)) { + $error .= "
      • " . ($line_num+2) . ": Failed validation. Error:
          $GT::SQL::error
        \n"; + $err_cnt++; + next LINE; + } + $good_cnt++; + } + +# Return the results. + if ($error) { + return $self->editor_import_data_form(($err_cnt >= 10) ? + "Aborting, too many errors!

        Rows imported: $good_cnt
        Errors with the following rows: +
          $error

        " : + "Rows imported: $good_cnt
        Errors with the following rows:
          $error

        "); + } + return $self->editor_import_data_form("Rows imported: $good_cnt."); +} +END_OF_SUB + +## +# $self->editor_export_data_form; +# ------------------------------- +# Prints the page to export data. +## +$COMPILE{editor_export_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Export Data from $table."); + +print qq~ + +~; + print $self->_start_form({ do => 'editor_export_data', db => $self->{cgi}->{db} }, {name => 'ExportForm'}); + + print qq~ +
        +

        You can either export your data from $table table to the screen or to a file. + If you have a large amount of + data it is recommended to export the contents to a file. Quick mode should be + used when exporting to a file as it + uses the SQL server to do the exporting and is considerably faster.
          +

        + + + +
        +
        + Fields to Export
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        + ~; + + print qq| +
        +
          +
        + Export data to: + filename:
        + Use as delimiter. +
        +
        + ~; + print $self->_buttons("Export Data from"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_export_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data { +# -------------------------------------------------------- +# Export data to text file/screen. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my ($delim, $quick, $res); + + $self->{cgi}->{'ExportRight'} or return $self->editor_export_data_form("No fields selected to export."); + my @order = reverse(ref $self->{cgi}->{'ExportRight'} eq 'ARRAY' ? @{$self->{cgi}->{'ExportRight'}} : $self->{cgi}->{'ExportRight'}); + + my $todo = 0; + for (@order) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_export_data_form("No fields selected to Export.") } + + $delim = $self->{cgi}->{'export-delim'}; + ($delim eq '\t') and ($delim = "\t"); + + if ($self->{cgi}->{'export-mode'} eq 'file') { + $self->{cgi}->{'export-file'} or return $self->editor_export_data_form("Please enter a file name!"); + $editor->export_data( + { + file => $self->{cgi}->{'export-file'}, + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form($GT::SQL::error); + return $self->editor_export_data_form("Data has been exported to: $self->{cgi}->{'export-file'}"); + } + else { + print $self->{in}->header; + $editor->export_data( + { + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form($GT::SQL::error); + return; + } +} +END_OF_SUB + +# ================================================================================ # +# PRIVATE/INTERNAL METHODS # +# ================================================================================ # + +## +# $self->_check_opts; +# ------------------- +# This checks to make sure the user specified at least one +# column to search on. +## +$COMPILE{_check_opts} = __LINE__ . <<'END_OF_SUB'; +sub _check_opts { + my $self = shift; + my $sel = 0; + +# Relation does not play fare :( + my $cols = $self->{table}->cols; + for (keys %{$self->{cgi}}) { $sel = 1 if (($self->{cgi}->{$_} =~ /\S/) and exists $cols->{$_}) } + if ((exists $self->{cgi}->{query} and $self->{cgi}->{query} =~ /\S/) or + (exists $self->{cgi}->{keyword} and $self->{cgi}->{keyword} =~ /\S/)) { + $sel = 1; + } + $sel or return; + return 1; +} +END_OF_SUB + +## +# $self->_header; +# --------------- +# Returns the header to be used with the forms, error pages, etc... +## +$COMPILE{_header} = __LINE__ . <<'END_OF_SUB'; +sub _header { + my ($self, $head, $msg) = @_; + if ($self->{header}) { + if (ref $self->{header} eq 'CODE') { + return $self->{header}->($self, $head, $msg); + } + else { + return $self->{header}; + } + } + else { + my $out = qq~ + + + + +
        + + + + + + + +
        + $self->{record}: $head +
        +

        $self->{record}: $head

        +

        $msg

        +
        +
        + ~; + } +} +END_OF_SUB + +## +# $self->_footer; +# --------------- +# Returns the footer to set for each form. +## +$COMPILE{_footer} = __LINE__ . <<'END_OF_SUB'; +sub _footer { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + if ($self->{footer}) { + if (ref $self->{footer} eq 'CODE') { + my $ret = $self->{footer}->($self); + return $ret if (defined $ret); + } + else { + return $self->{footer}; + } + } + my $url = GT::CGI->url({ query_string => 0 }) . "?"; + my @vals = GT::CGI->param('db'); + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + my $ret = qq~ +
        +
        +
        $self->{record}: + Add | + Modify | + Delete | + Search + ~; + if (!exists $self->{table}->{tables}) { + $ret .= qq~ | + Properties + ~; + } + $ret .= qq~ +
        +
        + ~; + return $ret; +} +END_OF_SUB + +$COMPILE{_prop_navbar} = __LINE__ . <<'END_OF_SUB'; +sub _prop_navbar { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + my @vals = GT::CGI->param('db'); + my $url = GT::CGI->url({ query_string => 0 }) . "?"; + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + return qq~ + +
        + + +
        Properties: + Add Column | + Delete Column | + Import Data | + Export Data | + Resync Database +
        +
        + ~; +} +END_OF_SUB + +## +# $self->_search_options; +# --------------- +# Returns the search options. +## +$COMPILE{_search_options} = __LINE__ . <<'END_OF_SUB'; +sub _search_options { + my $self = shift; + my $opts = shift; + if ($self->{search_options}) { + if (ref $self->{search_options} eq 'CODE') { + return $self->{search_options}->($self, $opts); + } + else { + return $self->{search_options}; + } + } + +# First, figure out the sort by columns. + my $c = $self->{table}->cols; + my ($hash, $order) = ({}, []); + foreach my $col (sort { + defined $c->{$a}->{pos} or warn "No pos for $a\n"; + defined $c->{$b}->{pos} or warn "No pos for $b\n"; + + $c->{$a}->{'pos'} <=> $c->{$b}->{'pos'} + } keys %$c) { + $hash->{$col} = $c->{$col}->{form_display} || $col; + push @$order, $col; + } + my $sb = $self->{html}->select( + { + name => "sb", + values => $hash, + sort_order => $order, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $so = $self->{html}->select( + { + name => "so", + values => { + 'ASC' => 'Ascending', + 'DESC' => 'Descending' + }, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $dr = $self->{html}->select( + { + name => "dr", + values => { + '' => 'As Elements', + 'rows' => 'As Rows' + }, + default => $self->{cgi}->{dr}, + blank => 1 + } + ); + +# Then set the rest of the form options. + my $ma = exists $self->{cgi}->{ma} ? 'CHECKED' : ''; + my $mh = exists $self->{cgi}->{mh} ? $self->{cgi}->{mh} : 25; + my $kw = exists $self->{cgi}->{keyword} ? $self->{cgi}->{keyword} : ''; + my $idx = exists $self->{cgi}->{indexed} ? $self->{cgi}->{indexed} : ''; + + my $out = qq~ + +
        + + + + + + + + + + + + + + + + + + + + + ~; + + if ( ( () = $self->{in}->param('db') ) == 1 ) { + $out .= qq~ + + + + + ~; + } + + if (exists $opts->{modify_mult} and $opts->{modify_mult}) { + $out .= qq~ + + + + + ~; + } + $out .= qq~ +
        Maximum Hits:Match Any:
        Keyword Search:
        Indexed Search:
        Sort By:$sbUsing:$so
        Display Records:$dr
        Modify Multiple:
        +
        + ~; + return $out; +} +END_OF_SUB + +## +# $self->_start_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_form} = __LINE__ . <<'END_OF_SUB'; +sub _start_form { + my $self = shift; + my $opts = shift || {}; + my $meth = exists $opts->{method} ? $opts->{method} : 'POST'; + my $attrib = shift || {}; + +# If a code ref was specified execute it and return the output to be printed + if ($self->{start_form}) { + if (ref $self->{start_form} eq 'CODE') { + return $self->{start_form}->($self, $opts, $meth); + } + else { + return $self->{start_form}; + } + } + +# Get the variables that need to be preserved and generate hidden tags for them. + my $preserve = $self->preserve(); + my $hidden_tags = ''; + foreach my $p (keys %$preserve) { + $hidden_tags .= qq||; + } + + my $out = ''; my @vals; + my $url = GT::CGI->url({ query_string => 0 }); + my $att = ' '; + $attrib->{name} ||= 'admin'; + foreach (keys %{$attrib}) { $att .= qq|$_="$attrib->{$_}" | } + foreach my $key (keys %$opts) { + next if ($key eq 'method'); + my $val = $opts->{$key}; + (ref $val eq 'ARRAY') ? (@vals = @$val) : (@vals = ($val)); + foreach my $val2 (@vals) { + $self->{html}->escape(\$val2); + $out .= qq~~; + } + } + my $mimeenc = $self->{table}->_file_cols() ? 'enctype="multipart/form-data"' : ''; + return qq~

        $hidden_tags$out\n~; +} +END_OF_SUB + +## +# $self->_end_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_form} = __LINE__ . <<'END_OF_SUB'; +sub _end_form { + my $self = shift; + if (defined $self->{end_form} and $self->{end_form}) { + if (ref $self->{end_form} eq 'CODE') { + return $self->{end_form}->($self); + } + else { + return $self->{end_form}; + } + } + return "
        \n"; +} +END_OF_SUB + +## +# $self->_start_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_html} = __LINE__ . <<'END_OF_SUB'; +sub _start_html { + my $self = shift; + my $opts = shift || {}; + if ($self->{start_html}) { + if (ref $self->{start_html} eq 'CODE') { + return $self->{start_html}->($self, $opts); + } + else { + return $self->{start_html}; + } + } + my $title = exists $opts->{title} ? $opts->{title} : ''; + my $body = exists $opts->{body} ? $opts->{body} : $BODY; + return qq~\n$title: $self->{record}\n~; +} +END_OF_SUB + +## +# $self->_end_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_html} = __LINE__ . <<'END_OF_SUB'; +sub _end_html { + my $self = shift; + if ($self->{end_html}) { + if (ref ($self->{end_html}) eq 'CODE') { + return $self->{end_html}->($self); + } + else { + return $self->{end_html}; + } + } + return "\n\n"; +} +END_OF_SUB + +## +# $self->_buttons; +# ------------------------- +# Display closing table with form buttons. +## +$COMPILE{_buttons} = __LINE__ . <<'END_OF_SUB'; +sub _buttons { + my $self = shift; + my $name = shift; + return qq~ +
        +
        +
        + ~; +} +END_OF_SUB + +$COMPILE{_index_list} = __LINE__ . <<'END_OF_SUB'; +sub _index_list { + my ($self, $column) = @_; + my $indexed = $self->{cgi}->{index} || 'none'; + if ($column and ! $self->{cgi}->{index}) { + $indexed = + $self->{table}->_is_indexed($column) ? 'regular' : + $self->{table}->_is_unique($column) ? 'unique' : + $self->{table}->_is_pk($column) ? 'primary' : + 'none'; + } + if ($column and $indexed eq 'primary') { + return "Primary Key"; + } + my $output = '"; + return $output; +} +END_OF_SUB + +$COMPILE{_index_type} = __LINE__ . <<'END_OF_SUB'; +sub _index_type { + my ($self, $column) = @_; + my $indexed = 'none'; + if ($column) { + $self->{table}->_is_indexed($column) and ($indexed = 'regular'); + $self->{table}->_is_unique($column) and ($indexed = 'unique'); + $self->{table}->_is_pk($column) and ($indexed = 'primary'); + } + return $indexed; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Admin - instant admin for any sql table. + +=head1 SYNOPSIS + + my $cgi = new GT::CGI; + my $db = new GT::SQL '/path/to/def'; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process(db => $db, cgi => $cgi); + } + +=head1 DESCRIPTION + +GT::SQL::Admin provides an easy way to build a table/relation +management application. It provides all the HTML and code to +easily: + + 1. Add records + 2. Delete records + 3. Modify records + 4. Search records + 5. Add columns + 6. Drop columns + 7. Alter table properties + 8. Import data + 9. Export data + +all in about 6 lines of code. + +=head2 Usage + +To use GT::SQL::Admin you need to pass in an existing +L object, and a L object. + +In it's simplest usage, you can simply call: + + my $admin = new GT::SQL::Admin; + $admin->process(db => $db, cgi => $cgi); + +and the admin module will figure out what was requested and display +the appropriate screen. There is a $admin->for_me method that will +look to see if the cgi object contains something for the admin +to do, returning 1 if yes, 0 otherwise. You would then do: + + my $cgi = new GT::CGI; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process(db => $db, cgi => $cgi); + } + +You can also call any of the methods individually. You can create an +add form like: + + $admin->add_form; + +and it will be printed to STDOUT. + +To change the look of a page, you can pass in strings or code refs +to display any of the following items: + + start_html + header + start_form + end_form + footer + end_html + +and the admin will use your html/code when displaying. You can also pass +in to process: + + record => 'MyObject' + +and the admin will use that string when displaying titles like 'Add MyObject'. +If you don't specify, it will default to the name of the table. + +=head2 Subclassing the admin + +You can enhance the functionality of an admin quite easily. By default +GT::SQL::Admin expects to find a GT::SQL object, a GT::CGI object, and uses +internally a GT::SQL::Display::HTML object for any form/record html +generation. + +Alternatively, you can subclass one or more of the above and use your +own libraries. For instance, if you wanted to expand the form generation, +you could subclass the GT::SQL::Display::HTML object and override the display() +and form() method with your own. + +The admin will pass in a 'mode' to both display and form that will tell +you what it is using the form for. This can be one of: + + search_form + search_results + add_form + add_success + delete_search_form + delete_search_results + download_file + modify_search_form + modify_search_results + modify_form + modify_success + modify_multi_search_results + modify_multi_results_norec + modify_multi_result_changed + modify_multi_results_err + + +There are also several options that can be passed in. See the +L module for more information. + +Also be sure to read about subclassing in L. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Admin.pm,v 1.161 2009/05/11 22:57:15 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Base.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Base.pm new file mode 100644 index 0000000..446a6eb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Base.pm @@ -0,0 +1,607 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# CVS Info : 087,071,086,086,085 +# $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt 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.72 $ =~ /(\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} and $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} and $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} and $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 "")) { + push @ins, [$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 %{$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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm new file mode 100644 index 0000000..cea3d79 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm @@ -0,0 +1,404 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 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.45 $ =~ /(\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 $_[-1] and (uc $_[-1] eq 'AND' or uc $_[-1] eq 'OR' or $_[-1] 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 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 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 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 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.45 2006/02/16 20:26:14 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Creator.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Creator.pm new file mode 100644 index 0000000..d4634a6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Creator.pm @@ -0,0 +1,1216 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Creator; +# =============================================================== +use GT::SQL; +use GT::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $error $ERROR_MESSAGE/; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.74 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::Base/; +$DEBUG = 0; + +sub new { +# ------------------------------------------------------------------- +# Setup a new creator object. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = {}; + if (@_ == 0) { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). No arguments") } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (not @_ % 2) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). Wrong arguments") } + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH); No table passed in to creator."); + + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + + $self->debug("OBJECT CREATED") if $self->{_debug} > 2; + return $self; +} + +## +# $obj->create; +# ------------------- +# Checks to see that the table is not there. +# Returns undef if it is. If the table is not +# there creates the table. +# +# $obj->create("force"); +# ----------------------------- +# This will check to see if the table is there. +# If it is create_table will drop the table +# then create the current one. +## +sub create { + my $self = shift; + my $force = shift || 'check'; + my $opts = shift || {}; + + $self->{table}->connect() or return; +# Error checking + $self->{table}->check_schema or return; + keys %{$self->{table}->cols} or return $self->fatal('NOTABLEDEFS'); + if ($self->_uses_weights) { $self->_get_indexer()->pre_create_table() or return } + + my $table_name = $self->{table}->name(); + +# Force the creation if force is specified + if ($force eq 'force') { + $self->debug("Forcing the table creation") if $self->{_debug} > 1; + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + $self->debug("Table $table_name exists. Dropping table") if ($self->{_debug} > 1); + $self->drop_table; + } + else { + $self->debug("Not dropping table $table_name because it does not exist") if $self->{_debug} > 1; + } + } + elsif ($force eq 'check' or $force eq 'upgrade' ) { + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + if ( $force eq 'upgrade' ) { + return $self->_consolidate( $opts ); + } + else { + return $self->warn(TBLEXISTS => $table_name); + } + } + } + + $self->{table}->{driver}->create_table($force) or return; + + +# Set up some defaults + $self->set_defaults; + $self->{table}->save_state or return; + +# now that the table has been made, if the user has requested weighted-indexing of tables, handle that + if ($self->_uses_weights) { $self->_get_indexer()->post_create_table() or return } + +# then handle anything related to file databases + $self->_file_create_tables(); + return 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if $self->{_debug} > 2; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +$COMPILE{_file_create_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_create_tables { +# creates file upload tables if required + my $self = shift; + + if ( $self->{table}->_file_cols() ) { + +# ... create the table because we have file columns + require GT::SQL::File; + my $ftable = GT::SQL::File->new( + table => $self->{table}, + connect => $self->{connect} + ); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + + }; + $self->{table}->_file_cols(1); +} +END_OF_SUB + +sub set_defaults { + my $self = shift; + my %cols = ref $_[0] ? %{shift()} : $self->{table}->cols(); + my %file_defs = (form_type => 'FILE', form_size => '20', file_save_in => '.', file_save_scheme => 'HASHED'); + + for my $col (keys %cols) { + + my $attrib = $cols{$col}; + if ($attrib->{type} =~ /char/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + + if ($attrib->{form_type} and $attrib->{form_type} =~ /file/i) { + my $col_info = $self->{table}->{schema}->{cols}->{$col}; + for (qw(form_type form_size file_save_in file_save_scheme)) { + $col_info->{$_} ||= $file_defs{$_} unless $col_info->{$_}; + } + + $col_info->{file_log_path} ||= $col_info->{file_save_in}; + } + } + elsif ($attrib->{type} =~ /text|blob/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXTAREA'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 30; + } + elsif ($attrib->{type} =~ /int|double|float/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 10; + } + elsif ($attrib->{type} =~ /enum/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'SELECT'; + } + elsif ($attrib->{type} =~ /date|timestamp/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'DATE'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + } + } + +} + + +## +# $obj->load_table; +# ----------------- +# Creates a schema based on an existing sql +# table and saves it. +## +$COMPILE{load_table} = __LINE__ . <<'END_OF_SUB'; +sub load_table { + my $self = shift; + $self->{table}->connect() or return; + $self->_load_table(@_) or return; + $self->{table}->save_state() or return; +} +END_OF_SUB + +$COMPILE{_load_table} = __LINE__ . <<'END_OF_SUB'; +sub _load_table { + my $self = shift; + $self->debug("DESCRIBE $self->{table}->{name}") if $self->{_debug}; + my $sth = $self->{table}->{driver}->prepare("DESCRIBE $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pos, %index, %unique, %cols, @pk, %other) = (1); + + # Default to the current ai value, if any, because some databases don't + # associate an increment to a value (such a postgres, where sequences are + # completely separate from tables and columns) + my $ai = $self->{table}->ai; + + my $table_name = $self->{table}->name; + my %col_case_map = map { lc $_ => $_ } keys %{$self->{table}->cols}; + my %index_case_map = map { lc $_ => $_ } keys %{$self->{table}->index}; + my %unique_case_map = map { lc $_ => $_ } keys %{$self->{table}->unique}; + +# Get the column defintions. + while (my $col = $sth->fetchrow_hashref) { + my $name = $col_case_map{lc $col->{Field}} || $col->{Field}; + my $type = $col->{Type}; + my $not_null = $col->{Null} ? 0 : 1; + my $default = ($col->{Default} and $col->{Default} ne 'NULL') ? $col->{Default} : undef; + $ai = $name if $col->{Extra} and $col->{Extra} =~ /AUTO/i; + $_ = $type; + + if (/^((?:var)?char)\((\d+)/i) { + %other = (type => uc $1, size => $2); + $other{binary} = 1 if /binary/i; + } + elsif (/^(var)?binary\((\d+)/i) { + %other = (type => "\U${1}char", size => $2); + $other{binary} = 1; + } + elsif (/^((?:tiny|small|medium|big)?int)/i) { + %other = (type => uc $1); + $other{zerofill} = 1 if /zerofill/i; + $other{unsigned} = 1 if /unsigned/i; + } + # decimal(10,5) + elsif (/^(?:decimal)\((\d+),\s*(\d+)\)/i) { + %other = (type => 'DECIMAL', precision => $1, scale => $2); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:double|float8)/i) { + %other = (type => 'DOUBLE'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:float|real)/i) { + %other = (type => 'REAL'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(datetime|date|timestamp|time|year|(?:tiny|medium|long)?(?:text|blob))/i) { + %other = (type => uc $1); + } + elsif (/^enum\('([^\)]+)'\)/i) { + %other = ( + type => 'ENUM', + values => [split /'\s*,\s*'/, $1] + ); + } + else { + return $self->fatal(BADTYPE => $type); + } + my %col = ( + pos => $pos, + %other + ); + $col{default} = $default if defined $default; + $col{not_null} = 1 if $not_null; + $cols{$name} = \%col; + $pos++; + } + + # Retrieve index information + $sth = $self->{table}->{driver}->prepare("SHOW INDEX FROM $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pk_index_name, @pk_index_cols); + while (my $index = $sth->fetchrow_hashref) { + my $name = lc $self->{table}->{driver}->extract_index_name($self->{table}->{name}, $index->{index_name}); + $name = ($index->{index_unique} ? $unique_case_map{$name} : $index_case_map{$name}) || $name; + my $field = $col_case_map{lc $index->{index_column}} || $index->{index_column}; + if ($index->{index_primary}) { + push @pk, $field if $index->{index_primary}; + # Ignore primary indexes that we don't know about because pk's CAN + # overlap regular indexes in some databases + next unless exists $unique_case_map{$name} or exists $index_case_map{$name}; + } + if ($index->{index_unique}) { + push @{$unique{$name}}, $field; + } + else { + push @{$index{$name}}, $field; + } + } + + my $old_cols = $self->{table}->cols; + for my $col (keys %cols) { + for my $val (keys %{$old_cols->{$col}}) { + $cols{$col}->{$val} = $old_cols->{$col}->{$val} unless exists $cols{$col}->{$val}; + } + } + $self->{table}->cols(\%cols); + $self->{table}->pk(@pk); + $self->{table}->ai($ai || ''); + $self->{table}->index(\%index); + $self->{table}->unique(\%unique); + + return 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + require GT::SQL::Editor; +# Were ->{fk} there, Editor would wipe the current table from all fk_tables + my $fk = delete $self->{table}->{schema}->{fk}; + my $ret = GT::SQL::Editor->new( + debug => $self->{_debug}, + table => $self->{table}, + connect => $self->{table}->{connect} + )->drop_table(@_); + $self->{table}->{schema}->{fk} = $fk; + $ret; +} +END_OF_SUB + +## +# $obj->clear_schema +# ------------------ +# Resets the schema to an empty schema. +## +sub clear_schema { + my $self = shift; + + %{$self->{table}->{schema}} = ( + index => {}, + unique => {}, + cols => {}, + pk => [], + fk => {}, + subclass => {}, + ai => '', + fk_tables => [] + ); + $self->{table}->{search_driver} = 'NONINDEXED'; +} + +## +# $obj->cols($hash_ref); +# --------------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# -------------------------- +# Sets the relations columns as specified via method +# params. +## +sub cols { + my $self = shift; + return $self->{table}->cols(@_); +} + +## +# $obj->pk($array_ref); +# -------------------------- +# Sets relation primary key, $array_ref is the +# reference to an array which looks like +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# ------------------------------------- +# Sets relation primary key given the fields +# which are in parameter. +## +sub pk { + my $self = shift; + $self->{table}->pk(@_) or return; + return 1; +} + +## +# $obj->ai($column); +# ----------------------- +# Sets the AUTO INCRIMENT column. +## +sub ai { + my $self = shift; + $self->{table}->ai(@_) or return; + return 1; +} + +## +# $obj->name($table_name); +# ----------------------------- +# Sets the name for the table to create. +## +sub name { + my $self = shift; + $self->{table}->name(@_) or return; + return 1; +} + +## +# $obj->form_display($nice_name); +# ------------------------ +# Sets the name of the table as it is displayed +# using the Display module. +## +sub form_display { + my $self = shift; + $self->{table}->form_display(@_) or return; + return 1; +} + +## +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index( +# { +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# } +# ); +# ---------------------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +## +sub index { + my $self = shift; + $self->{table}->index(@_) or return; + return 1; +} + +## +# $obj->search_driver( $searching_driver ); +# -------------------------------------------------- +## +sub search_driver { + my $self = shift; + $self->{table}->search_driver(@_) or return; + return 1; +} + +## +# $obj->unique($index_name, $col1, ..., $coln); +# -------------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +## +sub unique { + my $self = shift; + $self->{table}->unique(@_) or return; + return 1; +} + +## +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_1, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ----------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME => { SOURCE_FIELD_1 => TARGET_FIELD }); +# -------------------------------------------------------------- +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +sub fk { + my $self = shift; + $self->{table}->fk(@_) or return; + return 1; +} + +sub subclass { return shift->{table}->subclass(@_) } + +## +# $obj->save_schema +# Saves the schema (.def) file. Useful when loading tables +# that already exist, but you don't want to overwrite. +## +sub save_schema { + return unless ($_[0]->{table}); + return $_[0]->{table}->save_state(); +} + +$COMPILE{_consolidate} = __LINE__ . <<'END_OF_SUB'; +sub _consolidate { +#------------------------------------------------------------------------------- + my $self = shift; + my $opts = shift; + my $long_name = $self->{table}->{name}; + my $table_name = $long_name; + my $prefix = $self->{connect}->{PREFIX}; + $table_name =~ s,^$prefix,,; + + my $file = "$self->{connect}->{def_path}/$long_name.def"; + +# $self->clear_schema(); + my $table = $self->{table}->table( $table_name ) or die $GT::SQL::error; + + $table->connect(); + my $source = $table->{schema}; + my $destination = $self->{table}->{schema}; + +# HANDLE COLUMNS + my $s_cols = $source->{cols}; + my $d_cols = $destination->{cols}; + +# special vars + my ( %POSITION, %CHANGED, %REMOVED, %ADDED ); + +# compare the table columns from source to destination + my ( $cols, %col_order ); + %col_order = map { $_ => $s_cols->{$_}->{'pos'} } keys %$s_cols; + + for my $col_name ( keys %col_order ) { + + if ( $d_cols->{$col_name} ) { + + if ( _is_different( $d_cols->{$col_name}, $s_cols->{$col_name} ) ) { + + for my $option ( %{$d_cols->{$col_name}} ) { + + my $d_opts = $d_cols->{$col_name}; + my $s_opts = $s_cols->{$col_name}; + + if ( $option eq 'pos' ) { + if ( $d_opts->{pos} != $s_opts->{pos} ) { + $POSITION{$col_name} = $d_opts; + }; + } + + elsif ( ref $d_opts->{$option} eq 'ARRAY' ) { + my $d_ar = $d_opts->{$option}; + my $s_ar = $s_opts->{$option}; + if ( @$d_ar != @$s_ar ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + else { + for my $index ( 0..( scalar(@$d_ar)-1 ) ) { + if ( $d_ar->[$index] != $s_ar->[$index] ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + } + } + } + + else { + ( $d_opts->{$option} ne $s_opts->{$option} ) and $CHANGED{$col_name} = $d_cols->{$col_name}; + } + + } + + } + + } + + else { + $REMOVED{$col_name} = $s_cols->{$col_name}; + }; + + } + +# compare the table columns from destination to source + %col_order = map { $_ => $d_cols->{$_}->{'pos'} } keys %$d_cols; + for my $col_name ( keys %col_order ) { + if ( !$s_cols->{$col_name} ) { + $ADDED{$col_name} = $d_cols->{$col_name}; + } + } + +# HANDLE INDEXES + my $d_idx = $destination->{index}; + my $s_idx = $source->{index}; + my %index_order = map { $_ => 1 } ( keys %$d_idx, keys %$s_idx ); + my %INDEXES = (); + for my $idx_name ( keys %index_order ) { + if ( $d_idx->{$idx_name} and $d_idx->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_idx->{$idx_name} || []}; + my $d_cols = join "|", sort @{$s_idx->{$idx_name} || []}; + if ( $s_cols ne $d_cols ) { + $INDEXES{$idx_name} = $d_idx->{$idx_name}; + } + else { + $INDEXES{$idx_name} = 'EQ'; + } + } + elsif ( !$d_idx->{$idx_name} and $s_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'REMOVED'; + } + elsif ( !$s_idx->{$idx_name} and $d_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'ADDED'; + } + } + +# HANDLE AUTOINCREMENT + my $AI = undef; + if ( $destination->{ai} eq $source->{ai} ) { + $AI = 'EQ'; + } + else { + $AI = $destination->{ai}; + } + +# HANDLE PK + my $PK = undef; + $d_cols = join "|", sort @{$destination->{pk} || []}; + $s_cols = join "|", sort @{$source->{pk} || []}; + if ( $d_cols eq $s_cols ) { + $PK = 'EQ'; + } + else { + $PK = $destination->{pk}; + } + +# HANDLE FK + my %FK = (); + my $d_fk = $destination->{fk}; + my $s_fk = $source->{fk}; + %index_order = map { $_ => 1 } ( keys %$d_fk, keys %$s_fk ); + for my $col_name ( keys %$d_fk ) { + if ( _is_different( $d_fk->{ $col_name }, $s_fk->{ $col_name } ) ) { + $FK{$col_name} = $s_fk->{ $col_name }; + } + else { + $FK{$col_name} = 'EQ'; + } + } + +# HANDLE SUBCLASS + my %SUBCLASS = (); + my $d_sc = $destination->{subclass}; + my $s_sc = $source->{subclass}; + %index_order = map { $_ => 1 } ( keys %$d_sc, keys %$s_sc ); + for my $key ( keys %index_order ) { + if ( _is_different( $d_fk->{ $key }, $s_fk->{ $key } ) ) { + $SUBCLASS{ $key } = $d_fk->{ $key } ; + } + else { + $SUBCLASS{ $key } = 'EQ'; + } + } + +# HANDLE UNIQUE + my $d_uni = $destination->{unique}; + my $s_uni = $source->{unique}; + my %unique_order = map { $_ => 1 } ( keys %$d_uni, keys %$s_uni ); + my %UNIQUE = (); + for my $idx_name ( keys %unique_order ) { + if ( $d_uni->{$idx_name} and $d_uni->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_uni->{$idx_name}}; + my $d_cols = join "|", sort @{$s_uni->{$idx_name}}; + if ( $s_cols ne $d_cols ) { + $UNIQUE{$idx_name} = $d_uni->{$idx_name}; + } + else { + $UNIQUE{$idx_name} = 'EQ'; + } + } + elsif ( !$d_uni->{$idx_name} and $s_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'REMOVED'; + } + elsif ( !$s_uni->{$idx_name} and $d_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'ADDED'; + } + }; + +# Summon callback if required + $opts->{callback} and ( &{$opts->{callback}}( $self, $table, \%POSITION, \%CHANGED, \%REMOVED, \%ADDED, \%INDEXES, $AI, $PK, \%SUBCLASS, \%UNIQUE ) or return ); + +# if position movements are required we must read all the data into a temp +# table first + my $DO_POSITION = 0; + $DO_POSITION = $self->_create_temp_table( $table ); + +# ... change columns drop the columns + my $sth = $table->do_query(qq!DROP TABLE $long_name!) or die $GT::SQL::error; + +# change the columns that have to be changed. + $self->create( 'force' ) or die $GT::SQL::error; + +# ... add the columns that have been removed in the past + if ( %REMOVED and $self->{carry_over_columns} ) { + my $editor = $self->{table}->editor($table_name); + my $pos = scalar( keys %{$destination->{cols}} ); + for my $col_name ( sort { $REMOVED{$a}->{pos} <=> $REMOVED{$b}->{pos} } keys %REMOVED ) { + $REMOVED{$col_name}->{pos} = ++$pos; + $editor->add_col( $col_name, $REMOVED{$col_name} ) or die $GT::SQL::error; + } + } + +# ... now copy the data over + $cols = $source->{cols}; + my $copy_cols = join ",", + sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } + grep { $self->{carry_over_columns} ? 1 : not $REMOVED{$_} } + keys %$cols; + $table->do_query(qq! + INSERT INTO $long_name + ($copy_cols) + SELECT $copy_cols + FROM $DO_POSITION + !) or die $GT::SQL::error; + + if ( %CHANGED ) { + my $editor = $self->{table}->editor($table_name); + for my $col_name ( keys %CHANGED ) { + $editor->alter_col( $col_name, $CHANGED{$col_name} ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_create_temp_table} = __LINE__ . <<'END_OF_SUB'; +sub _create_temp_table { +#------------------------------------------------------------------------------- +# + my $self = shift; + my $table = shift; + my $source = $table->{schema}; + my $def_path = $self->{connect}->{def_path}; + + use GT::MD5; + my $table_name = ''; + while ( -e ( $def_path . ( $table_name = GT::MD5::md5_hex( time() * rand() * 10000 ) ) ) ) {}; + my $c = $table->creator( $table_name ); + my $struct = _copy_struct( $source ); + $struct->{fk_tables} = {}; + $struct->{fk} = {}; + $struct->{subclass} = {}; + for ( values %{$struct->{cols}} ) { delete $_->{weight}; } + + $c->cols( %{$struct->{cols}} ); + %{$c->{table}->{schema}} = %$struct; + $c->create( "force" ) or die $GT::SQL::error; + + my $tbl = $table->table( $table_name ); + my $s_name = $table->name(); + my $d_name = $tbl->name(); + + $tbl->connect(); + $tbl->do_query(qq|INSERT INTO $d_name SELECT * FROM $s_name|) or die $GT::SQL::error; + + return $table_name; +} +END_OF_SUB + +$COMPILE{_copy_struct} = __LINE__ . <<'END_OF_SUB'; +sub _copy_struct { +#------------------------------------------------------------------------------- +# + my $source = shift; + my $copied_struct = undef; + + if ( ref $source eq 'HASH' ) { + $copied_struct = {}; + for my $key ( keys %$source ) { + $copied_struct->{ $key } = _copy_struct( $source->{$key} ); + } + } + + elsif ( ref $source eq 'ARRAY' ) { + $copied_struct = []; + for my $element ( @$source ) { + push @$copied_struct, _copy_struct( $element ); + } + } + + else { + $copied_struct = $source; + } + + return $copied_struct; +} +END_OF_SUB + + +$COMPILE{_is_different} = __LINE__ . <<'END_OF_SUB'; +sub _is_different { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return 1 } + + if ( ref $source eq 'HASH' ) { + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + for my $key ( keys %keys ) { + _is_different( $source->{$key}, $destination->{$key} ) and return 1; + } + } + + elsif ( ref $source eq 'ARRAY' ) { + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + my $count = ( $ca > $cb ) ? $ca : $cb; + for my $index ( 0 .. ( $count - 1 ) ) { + _is_different( $source->[$index], $destination->[$index] ) and return 1; + } + } + + else { + ( $source ne $destination ) and return 1; + } + + return; +} +END_OF_SUB + +$COMPILE{_compare} = __LINE__ . <<'END_OF_SUB'; +sub _compare { +#------------------------------------------------------------------------------- +# takes a hashref or arrayref and compares the two +# + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return [ 'NE_TYPES', ref $source, ref $destination ]; } + + if ( ref $source eq 'HASH' ) { + return _comp_hash( $source, $destination ); + } + elsif ( ref $source eq 'ARRAY' ) { + return _comp_array( $source, $destination ); + } + else { + return; + } + +} +END_OF_SUB + +$COMPILE{_comp_hash} = __LINE__ . <<'END_OF_SUB'; +sub _comp_hash { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my %errs; + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + + for my $key ( keys %keys ) { + + my $src = $source->{$key}; + my $dst = $destination->{$key}; + if ( ref $src or ref $dst ) { + $errs{$key} = _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + $errs{$key} = 'EQ'; + } + else { + $errs{$key} = [ 'NE', $src, $dst ]; + } + + } + + return \%errs; +} +END_OF_SUB + +$COMPILE{_comp_array} = __LINE__ . <<'END_OF_SUB'; +sub _comp_array { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my @errs; + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + + my $count = ( $ca > $cb ) ? $ca : $cb; + + for my $index ( 0 .. ( $count - 1 ) ) { + + my $src = $source->[$index]; + my $dst = $destination->[$index]; + if ( ref $src or ref $dst ) { + push @errs, _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + push @errs, 'EQ'; + } + else { + push @errs, [ 'NE', $src, $dst ]; + } + + } + + return \@errs; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Creator - an object to create SQL tables. + +=head1 SYNOPSIS + + my $creator = $DB->creator('Newtable'); + $creator->cols( + col1 => { + pos => 1 + type => 'CHAR', + size => 50 + }, + col2 => { + pos => 2, + type => 'INT', + not_null => 1 + } + ); + $creator->pk('col2'); + $creator->ai('col2'); + $creator->create or die "Unable to create: $GT::SQL::error"; + +=head1 DESCRIPTION + +A creator object is used to build new SQL tables. + +To get a new creator object, you need to call creator() from an existing +GT::SQL object. + +The object that is returned has methods to set up your table. You will need to +call this method for each table you want to create. + + $creator = $obj->creator($table); + +You must pass in the name of the table you want to create. This means if you +have a table named C you must call C<-Ecreator> with C<'MyTable'> +as the argument. + + $creator = $obj->creator('MyTable'); + +From this point you can call create methods on your creator object to define +and create your table. + +=head2 cols + +I is used to define the columns that will be in the new table by setting +properties such as the type, whether it allows null values, unsigned etc. + +For detailed information on the types and options accepted, please see +L. The following describes the options accepted that do not +directly affect the underlying database: + +=over 4 + +=item values + +This specifies the values for the I column type. If you are using an +I this must be set. The value for this should be an array reference of +the possible values for the I column. The values in the array that is +passed in will be quoted by DBI's quote method. + +=item regex + +This is a regex that the value must pass before being inserted +into the database. + +=item form_display + +This is a "pretty name" that will be used by the HTML module +for creating attractive forms automatically. + +=item form_size + +This is the form field length to be used by the HTML module. + +=item form_type + +This is the type of form to use by the HTML module: select, checkbox +radio, text, textarea or hidden. + +=item form_names + +This is for multi select or checkboxes and is an array ref of names +that get displayed. + +=item form_values + +This is for multi select or checkboxes and is an array ref of the +actual values that will be stored in the database. + +=item time_check + +This is only useful for TIMESTAMP fields. If set to 1, the module +will not allow you to update a record which has an older timestamp +then what is in the database. This is very helpful for protecting +against multiple updates. + +=item weight + +By giving an item a weight, GT::SQL will maintain a search index +table, and use that search index table when called using query. +This is only useful for indexing large text fields and should not +be used normally. The higher the weight, the more influence that +column will have on the result. So if a Title was set to weight +3 and a Description to weight 1, then when doing a search, a match +in the title would make the result appear before a match in the +description. + +=back + +So an example would look like: + + $creator->cols( + $col1 => { + type => 'ENUM', + values => ['val1', 'val2' ... ], + not_null => 1 + }, + $col2 => { + ... + } + ); + +Sets the relations columns as specified via method +parameters. The only required key for the has is type. +However some column types require other values be set +such as I requires you specify the values. + +=head2 pk + +C lets you specify the primary keys for the current table. +This method can be called with an array of primary key columns +in which case all the specified column names in the array will +make up the primary keys. If you call it with a single scalar +value this is assumed to be the primary key for the table. + + $creator->pk($field1, $field2, ...); + +=head2 ai + +This specifies the auto increment column for the current table. +There can be only one auto increment column per table, it must +be a numeric type, it must be not null and it must be the +primary key. This limitation is checked when you call create. +If it is not a numeric column type you will get a fatal error +when you call create. If any of the other limitations fail +the creator class will correct. + +=head2 index + +C allows you to specify the name and the columns for you +table indexes. + +There are two ways to call this method. + +You can set up all your indexes at once by calling it with +hash reference like this: + + $creator->index({ + $index1 => [field1, field2], + $index2 => [field3, field4] + }); + +The keys to this hash reference are the index names and +the values are an array reference containing the columns +that are part of the named index. The order for these +columns are maintained during the create. + +You can also pass in one index at a time like this; + + $creator->index($index_name, $col1, ..., $coln); + +The first argument is the name of the index and all the +rest are treated as columns that are part of this index. +Again the order of the columns are maintained. + +=head2 unique + +The C method allows you to specify the unique +indexes for the current table. This method takes the +same arguments as the C method. + +=head2 fk + +C allows you to specify foreign key relations for your +tables. You CAN NOT specify foreign keys for tables that +have not been created yet. There are two ways to pass in +arguments to C. The first way is passing in a hash reference. + + $creator->fk({ + $FOREIGN_TABLE_NAME => + { + $LOCAL_TABLE_COL_1 => $FOREIGN_TABLE_COL_1, + ... + $LOCAL_TABLE_COL_n => $FOREIGN_TABLE_COL_n + } + }); + +The keys to the hash are the names of the tables you are relating to. +The values are a hash reference that contain the name of the current +tables columns as the keys and the name of the foreign tables columns +that we are relating to as the values. + +You cannot relate fields to your self. You also need to be careful +not to create circular references. This is checked when you call this +method. If there is a circular reference detected you will receive a +fatal error. + +Foreign keys currently effect selects only. + +=head2 search_driver + +This affects how the weighted records are indexed. By default the +system will attempt to use best driver for the DBMS. However, if +you'd like to force the indexing system to an alternative type, such +as for MYSQL you can use this. + +* note: though the MYSQL driver is faster, the internal indexing system +has better support for phrase searching and keyword searching. + +To set the driver, call C with the appropriate driver +name. The following example will force the system into using the +internally implemented indexing scheme. + + $creator->search_driver('INTERNAL'); + +Currently, the only other valid option is "MYSQL". + +-note- + +The MYSQL driver occasionally behaves oddly with a small number of +records. In that case, set the search scheme to "INTERNAL". + +=head2 create + +This is the method you call to create your table after you have specified +all your table definitions. Several checks are made when this method is +called to ensure the table is created correctly. + +One of the things that is done is checking to see that the table you are +trying to create does not exist. If the table does exist I will +return undefined and set the error in $GT::SQL::error. + +You can specify to have C drop the table by passing in "force". + + $creator->create('force'); + +-or- + + $creator->create; + +C returns true on success and undef on failure. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML.pm new file mode 100644 index 0000000..c0ccde0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML.pm @@ -0,0 +1,893 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Display::HTML +# Author: Scott & Alex +# $Id: HTML.pm,v 1.98 2009/03/23 22:55:53 brewt 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.98 $ =~ /(\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' ) { + for (qw/_filename _del/) { + $values->{$col.$_} = $self->{values}->{$col.$_} if exists $self->{values}->{$col.$_}; + } + } + $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~~; +} + +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="multiple" size="$self->{cols}->{$clean_name}->{form_size}"!; + } + elsif (exists $opts->{multiple} and $opts->{multiple} > 1) { + $mult = qq! multiple="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}) ? qq| class="$opts->{def}->{class}"| : ""; + my $out = qq~~; + $blank and ($out .= qq~~); + +# 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~"; + } + $out .= "\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}) ? qq| 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 ~) and next KEY; + } + $out .= qq~$val ~; + } + 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}) ? qq| 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~) and next KEY; + } + $out .= qq~ $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~~; +} + +sub hidden_text { + my ($self, $opts) = @_; + my $out; + my $html = $self->_get_html_display; + $out .= "{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~~; + 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]} }); + + my $use_path = $self->{file_use_path} && -e $opts->{value}; + if ($use_path or $href) { + + require GT::SQL::File; + my $sfname = $values->{$colname."_filename"}; + $out = $sfname || GT::SQL::File->get_filename($fname ||= $href->{File_Name}); + $use_path and $out .= qq!!; + $sfname and $out .= qq!!; + + 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 => $use_path ? 'path' : 'db', + fname => $fname + }, + [qw( do id cn db src )] + ); + $out .= qq! {font}>download!; + $url = _reparam_url( + $self->{url}, + { + do => 'view_file', + id => $values->{$pk[0]}, + cn => $colname, + db => $dbname, + src => $use_path ? 'path' : 'db', + fname => $fname + }, + [qw( do id cn db src )] + ); + $out .= qq! {font}>view!; + } + my $checked = $values->{"${colname}_del"} ? ' checked="checked" ' : ''; + $out .= qq~ Delete~; + } + } + my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : ""; + $out .= qq~~; + + 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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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 .= "
        "; + } + } + } + + 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}>download!; + + $url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] ); + $val .= qq! {font}>view!; + } + + 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~[<<] ~); + ($nh > 1) and ($url .= qq~[<] ~); + 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~$i ~); + if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; } + } + $url .= qq~[>] ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits)); + $url .= qq~[>>] ~ 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', '=', '<>', '>', '<' ], + $val ||= '=', 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; + return unless $$t; + $$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. diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Relation.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Relation.pm new file mode 100644 index 0000000..e549e59 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Relation.pm @@ -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 .= '
        '; + + 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~~; + } + $self->{extra_table} and ($out .= "\n"); + return $out; +} + +sub mk_table { + my $self = shift; + my %opt = @_; + + my $out = ''; + $self->{extra_table} and ($out .= "

        "); + my $cols = $opt{table}->cols; + my $name = $opt{table}->name; + + $out .= qq( + {table}> + + ); + 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 .= "
        + $name +
        \n"; + $out .= "

        \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}>{td} width='$opt{cwidth}'>{col_font}>$display_name{td} width='$opt{vwidth}'>{val_font}>"; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self ); + + $out .= ""; + +# 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} width="10%">{val_font}>~; + $out .= $self->_mk_search_opts({ + name => $field_name, + def => $self->{cols}->{$col}, + pk => $is_pk + }) || ' '; + $out .= ""; + } + $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 diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Table.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Table.pm new file mode 100644 index 0000000..507196a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML/Table.pm @@ -0,0 +1,299 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Display::HTML +# Author: Scott & Alex +# $Id: Table.pm,v 1.29 2009/05/11 23:09:59 brewt 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.29 $ =~ /(\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 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{col_font}>!; + $out .= 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" ) : '' ) . ""; + $out .= qq!\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, $col); + 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{col_font}>!; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }); + + $out .= qq!\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 .= "
        "); + $out .= "{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 (ref $self->{code}->{$col} eq 'CODE') { + $out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values, $col); + 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}>"; + +# Display any search options if requested. + if ($self->{search_opts}) { + $out .= qq~"; + } + $out .= "\n"; + } + $out .= "
        {td} width='$cwidth'>{col_font}>$display_name{td} width='$vwidth'>{val_font}>"; + +# Get the column display subroutine + my $o = $self->$disp( + { + name => $field_name, + def => $self->{cols}->{$col}, + value => (defined $value ? $value : '') + }, + ($values || {}), + $self + ); + $out .= $o if defined $o; + +# Add edit/delete links next to the primary key in search results. + if ($self->{mode} eq 'search_results' and @{$self->{pk}} == 1 and $col eq $self->{pk}->[0]) { + my $url = GT::CGI->url({ query_string => 0 }) . '?'; + my @vals = GT::CGI->param('db'); + for my $val (@vals) { + $url .= 'db=' . GT::CGI->escape($val) . ';'; + } + chop $url; + $out .= qq| edit delete|; + } + $out .= "{td} width="10%">{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 .= "
        \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~~; + } + $self->{extra_table} and ($out .= "
        \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 diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver.pm new file mode 100644 index 0000000..e9c128c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver.pm @@ -0,0 +1,904 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver +# CVS Info : 087,071,086,086,085 +# $Id: Driver.pm,v 2.6 2005/11/03 01:38:30 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.6 $ =~ /(\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, '?'; + + # If the column is numeric, make sure a '' becomes a null, due to + # problems where old libraries or the table editor could have set the + # default to '': + if (defined $val and $val eq '' and $cols->{$col}->{type} =~ /^(?:INTEGER|REAL|FLOAT|DOUBLE|DECIMAL)$|INT$/) { + $val = undef; + } + 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm new file mode 100644 index 0000000..6891d2a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm @@ -0,0 +1,522 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::MSSQL +# CVS Info : 087,071,086,086,085 +# $Id: MSSQL.pm,v 2.7 2005/12/03 00:54:11 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 <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(<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 < 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. Actually, we look for 4000 because that's + # the worst-case scenario for escaping being able to increase to 8000 characters. + for (my $i = 0; $i < @_; $i++) { + if (defined $_[$i] and length $_[$i] > 4000) { + $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/
        /\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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm new file mode 100644 index 0000000..b54dd80 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm @@ -0,0 +1,226 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::MYSQL +# CVS Info : 087,071,086,086,085 +# $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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm new file mode 100644 index 0000000..1abcd0a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm @@ -0,0 +1,590 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::ORACLE +# CVS Info : 087,071,086,086,085 +# $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao 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; + # using ROWNUM to limit rows instead. + my $max_rows = $offset + $limit; + $query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $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(<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 <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/
        /\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}) { + while (my $rec = $self->{sth}->fetchrow_arrayref) { + my @tmp = @$rec; + pop @tmp; # get rid of the RNUM extra column + push @{$self->{_results}}, [@tmp]; # 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; +} + +$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _fetchrow_hashref { +# ----------------------------------------------------------------------------- +# Handles row fetching for driver that can't use the default ->fetchrow_hashref +# due to needing column case mapping ($sth->{hints}->{case_map}), or special +# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit +# handling). +# + my $self = shift; + + my %case_map; # returnedname => ReturnedName, but only for columns that use upper case + if ($self->{hints}->{case_map}) { + if (exists $self->{schema}->{cols}) { + my $cols = $self->{schema}->{cols}; + %case_map = map { lc $_ => $_ } keys %$cols; + } + else { + for my $table (keys %{$self->{schema}}) { + for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) { + $case_map{lc $col} = $col; + } + } + } + } + + if ($self->{_results}) { + my $arr = shift @{$self->{_results}} or return; + + my $i; + my %selected = map { lc $_ => $i++ } @{$self->{_names}}; + my %hash; + + for my $lc_col (keys %selected) { + next if $lc_col eq 'rnum'; + if (exists $case_map{$lc_col}) { + $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}]; + } + else { + $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}]; + } + } + return \%hash; + } + else { + my $h = $self->{sth}->fetchrow_hashref or return; + for (keys %$h) { + $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_}; + } + return $h; + } +} +END_OF_SUB + +# ----------------------------------------------------------------------------- +# 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm new file mode 100644 index 0000000..93432ee --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm @@ -0,0 +1,661 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::PG +# CVS Info : 087,071,086,086,085 +# $Id: PG.pm,v 2.3 2005/10/06 00:05:51 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: PostgreSQL driver for GT::SQL +# + +package GT::SQL::Driver::PG; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; +use DBI(); + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver/; + +sub protocol_version { 2 } + +sub connect { + my $self = shift; + my $dbh = $self->SUPER::connect(@_) or return; + + # This is really a hack to get things working somewhat accurately - ideally + # all data should be in UTF8, but GT::SQL and our products do not yet have + # any provision for such, and inserting iso8859-1 data into a unicode table + # causes fatal errors about invalid utf8 sequences. So, we set it to + # latin1 here in the hopes that it won't break too much, and let the + # application deal with it. There are still inherent problems here, + # however - if the database is latin5, for example, setting this to latin1 + # would make postgresql attempt to convert from latin1 -> latin5 on input + # and convert back on output, which is a potentially lossy conversion. + $dbh->do("SET NAMES 'LATIN1'"); + + return $dbh; +} + +sub dsn { +# ----------------------------------------------------------------------------- +# Creates a postgres-specific DSN, such as: +# DBI:Pg:dbname=database;host=some_hostname +# host is omitted if set to 'localhost', so that 'localhost' can be used for a +# non-network connection. If you really want to connect to localhost, use +# 127.0.0.1. +# + my ($self, $connect) = @_; + + $connect->{driver} ||= 'Pg'; + $connect->{host} ||= 'localhost'; + $self->{driver} = $connect->{driver}; + + my $dsn = "DBI:$connect->{driver}:"; + $dsn .= "dbname=$connect->{database}"; + $dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost'; + $dsn .= ";port=$connect->{port}" if $connect->{port}; + + return $dsn; +} + +sub hints { + prefix_indexes => 1, + fix_index_dbprefix => 1, + case_map => 1, + ai => sub { + my ($table, $column) = @_; + my $seq = "${table}_seq"; + my @q; + push @q, \"DROP SEQUENCE $seq"; + push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1"; + \@q; + }, + drop_pk_constraint => 1 +} + +$COMPILE{_version} = __LINE__ . <<'END_OF_SUB'; +sub _version { + my $self = shift; + return $self->{pg_version} if $self->{pg_version}; + my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION + if ($ver) { + local $^W; + $ver = sprintf "%.2f", $ver; + } + return $self->{pg_version} = $ver; +} +END_OF_SUB + +sub _prepare_select { +# ----------------------------------------------------------------------------- +# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format +# + my ($self, $query) = @_; + $query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i; + $query; +} + +sub _prepare_describe { +# ------------------------------------------------------------------ +# Postgres-specific describe code +# + my ($self, $query) = @_; + $query =~ /DESCRIBE\s*(\w+)/i + or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query"); + + # atttypmod contains the scale and precision, but has to be extracted using bit operations: + my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000) + my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000) + + <>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')' + ELSE t.typname + END AS "Type", + CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null", + ( + SELECT + CASE + WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#') + WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc + ELSE NULL + END + FROM pg_attrdef + WHERE adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Default", + ( + SELECT + CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END + FROM pg_attrdef d + WHERE d.adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Extra" +FROM + pg_class c, pg_attribute a, pg_type t +WHERE + a.atttypid = t.oid AND a.attrelid = c.oid AND + relkind = 'r' AND + a.attnum > 0 AND + c.relname = '\L$1\E' +ORDER BY + a.attnum +QUERY + +# The following could be used above for Key - but it's left off because SHOW +# INDEX is much more useful: +# ( +# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END +# FROM pg_index keyi, pg_class keyc, pg_attribute keya +# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid +# and indisprimary = 't' and keya.attname = a.attname +# ) AS "Key", +} + +sub column_exists { + my ($self, $table, $column) = @_; + my $sth = $self->{dbh}->prepare(< 0 AND + c.relname = ? AND a.attname = ? +EXISTS + $sth->execute(lc $table, lc $column); + + return scalar $sth->fetchrow; +} + +sub _prepare_show_tables { +# ----------------------------------------------------------------------------- +# pg-specific 'SHOW TABLES'-equivelant +# + <<' QUERY'; + SELECT relname AS tables + FROM pg_class + WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%') + ORDER BY relname + QUERY +} + +sub _prepare_show_index { +# ----------------------------------------------------------------------------- +# Get index list +# + my ($self, $query) = @_; + unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) { + return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query"); + } + <<" QUERY"; + SELECT + c.relname AS index_name, + attname AS index_column, + CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique, + CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary + FROM + pg_index i, + pg_class c, + pg_class t, + pg_attribute a + WHERE + i.indexrelid = c.oid AND + a.attrelid = c.oid AND + i.indrelid = t.oid AND + t.relname = '\L$1\E' + ORDER BY + i.indexrelid, a.attnum + QUERY +} + +sub drop_table { +# ----------------------------------------------------------------------------- +# Drops the table passed in - drops a sequence if needed. Takes a second +# argument that, if true, causes the sequence _not_ to be dropped - used when +# the table is being recreated. +# + my ($self, $table) = @_; + + my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'"); + $sth->execute(); + if (my $seq_name = $sth->fetchrow) { + $self->do("DROP SEQUENCE $seq_name") + or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error); + } + return $self->SUPER::drop_table($table); +} + +sub drop_column { +# ------------------------------------------------------------------- +# Drops a column from a table. +# + my ($self, $table, $column) = @_; + + my $ver = $self->_version(); + + # Postgresql 7.3 and above support ALTER TABLE $table DROP $column + return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03; + + $self->_recreate_table(); +} + +$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB'; +sub _recreate_table { +# ----------------------------------------------------------------------------- +# Adds/removes/changes a column, but very expensively as it involves recreating +# and copying the entire table. Takes argument pairs, currently: +# +# with => 'adding_this_column' # optional +# +# Keep in mind that the various columns depend on the {cols} hash of the table +# having been updated to reflect the change. +# +# We absolutely require DBI 1.20 in this subroutine for transaction support. +# However, we won't get here if using PG >= 7.3, so you can have either an +# outdated PG, or an outdated DBI, but not both. +# + my ($self, %opts) = @_; + + DBI->require_version(1.20); + my $ver = $self->_version; + + my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified'); + + my $cols = $self->{schema}->{cols}; + my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols; + + my (@copy_cols, @select_cols); + for (keys %$cols) { + push @copy_cols, "$_ " . $self->column_sql($cols->{$_}); + push @select_cols, $_; + } + + if ($opts{with}) { # a column was added, so we can't select it from the old table + @select_cols = grep $_ ne $opts{with}, @select_cols; + } + + $self->{dbh}->begin_work; + + my $temptable = "GTTemp" . substr(time, -4) . int rand 10000; + my $select_cols = join ', ', @select_cols; + my $lock = "LOCK TABLE $table"; + my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table"; + + my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable"; + my $drop_temp = "DROP TABLE $temptable"; + + for my $precreate ($lock, $createtemp) { + unless ($self->{dbh}->do($precreate)) { + $self->warn(CANTEXECUTE => $precreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + unless ($self->drop_table($table)) { + $self->{dbh}->rollback; + return undef; + } + + unless ($self->create_table) { + $self->{dbh}->rollback; + return undef; + } + + for my $postcreate ($insert, $drop_temp) { + unless ($self->{dbh}->do($postcreate)) { + $self->warn(CANTEXECUTE => $postcreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + $self->{dbh}->commit; + + return 1; +} +END_OF_SUB + +sub alter_column { +# ----------------------------------------------------------------------------- +# Changes a column in a table. The actual path done depends on multiple +# things, including your version of postgres. The following are supported +# _without_ recreating the table; anything more complicated requires the table +# be recreated via _recreate_table(). +# +# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20, +# everything else does) +# - adding/dropping a not null contraint, with >= 7.3 +# - any other changes, with >= 7.3, by adding a new column, copying data into +# it, dropping the old column +# +# Anything else calls _recreate_table(), which also requires DBI 1.20, but is +# much more involved as the table has to be dropped and recreated. +# + my ($self, $table, $column, $new_def, $old_col) = @_; + + my $ver = $self->_version; + return $self->_recreate_table() if $ver < 7; + + my $cols = $self->{schema}->{cols}; + my $new_col = $cols->{$column}; + + my @onoff = qw/not_null/; # true/false attributes + my @changeable = qw/default size scale precision/; # changeable attributes + my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff; + my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff; + my %change = map { ( + exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new + and ( + defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't + or + defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but != + ) + ) ? ($_ => 1) : () } @changeable; + + { + my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable; + my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable; + %add = (%add, %add_changeable); + %rem = (%rem, %rem_changeable); + } + + if ($ver < 7.03) { + # In 7.0 - 7.2, defaults can be added/dropped/changed, but anything + # more complicated needs a table recreation + if ( + keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default + or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default + or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default + ) { + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + my $ph; + if ($add{default} or $change{default}) { + $query .= "SET DEFAULT ?"; + $ph = $new_col->{default}; + } + else { + $query .= "DROP DEFAULT"; + } + $self->{dbh}->do($query, defined $ph ? (undef, $ph) : ()) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + return $self->_recreate_table(); + } + + # PG 7.3 or later + + if ( + keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL + or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL + ) { + # All we're doing is changing a not_null constraint + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + $query .= $rem{not_null} ? 'DROP' : 'SET'; + $query .= ' NOT NULL'; + $self->{dbh}->do($query) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + + if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8) + and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null + and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null + ) { + my @query; + # Change type (PG 8+ only) + if ($ver >= 8 and $change{type}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}"; + } + + # Change default + if ($add{default} or $change{default}) { + push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}]; + } + elsif ($rem{default}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT"; + } + + # Change not_null + if ($rem{not_null}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL"; + } + elsif ($add{not_null}) { + if ($add{default}) { + push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}]; + } + push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"; + } + + return $self->do_raw_transaction(@query); + } + + # We've got more complex changes than PG's ALTER COLUMN can handle; we need + # to add a new column, copy the data, drop the old column, and rename the + # new one to the old name. + my (@queries, %index, %unique); + + push @queries, "LOCK TABLE $table"; + my %add_def = %$new_col; + my $not_null = delete $add_def{not_null}; + my $default = delete $add_def{default}; + my $add_def = $self->column_sql(\%add_def); + my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000); + push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def"; + push @queries, "UPDATE $table SET $tmpcol = $column"; + push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default; + push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default; + push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null; + push @queries, "ALTER TABLE $table DROP COLUMN $column"; + push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column"; + + for my $type (qw/index unique/) { + while (my ($index, $columns) = each %{$new_col->{$type}}) { + my $recreate; + for (@$columns) { + if ($_ eq $column) { + $recreate = 1; + last; + } + } + next unless $recreate; + if ($type eq 'index') { + $index{$index} = $columns; + } + else { + $unique{$index} = $columns; + } + } + } + + $self->do_raw_transaction(@queries); + + while (my ($index, $columns) = each %index) { + $self->create_index($table, $index, @$columns); + } + while (my ($index, $columns) = each %unique) { + $self->create_unique($table, $index, @$columns); + } + + 1; +} + +sub add_column { +# ----------------------------------------------------------------------------- +# Adds a new column to the table. +# + my ($self, $table, $column, $def) = @_; + +# make a copy so the original reference doesn't get clobbered + my %col = %{$self->{schema}->{cols}->{$column}}; + +# Defaults and not_null have to be set _after_ adding the column. + my $default = delete $col{default}; + my $not_null = delete $col{not_null}; + + my $ver = $self->_version; + + return $self->_recreate_table(with => $column) + if $ver < 7 and defined $default or $ver < 7.03 and $not_null; + + my @queries; + + if (defined $default or $not_null) { + $def = $self->column_sql(\%col); + } + + push @queries, ["ALTER TABLE $table ADD $column $def"]; + + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default; + push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null; + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null; + + $self->do_raw_transaction(@queries); +} + +sub create_pk { + my ($self, $table, @cols) = @_; + my $ver = $self->_version; + if ($ver < 7.2) { + return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")"); + } + else { + # ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior + # versions we have to recreate the entire table. + return $self->_recreate_table(); + } +} + +sub drop_pk { +# ----------------------------------------------------------------------------- +# Drop a primary key. Look for the primary key, then call drop_index with it. +# + my ($self, $table) = @_; + + my $sth = $self->prepare("SHOW INDEX FROM $table") or return; + $sth->execute or return; + my $pk_name; + while (my $index = $sth->fetchrow_hashref) { + if ($index->{index_primary}) { + $pk_name = $index->{index_name}; + last; + } + } + + $pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table"); + + $self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name"); +} + +sub ai_insert { + my ($self, $ai) = @_; + return $ai, "NEXTVAL('$self->{name}_seq')"; +} + +sub insert_multiple { +# ----------------------------------------------------------------------------- +# Performs multiple insertions in a single transaction, for much better speed. +# + my $self = shift; + + # ->begin_work and ->commit were not added until 1.20 + return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20; + + $self->{dbh}->begin_work; + my ($cols, $args) = @_; + + my $names = join ",", @$cols, $self->{schema}->{ai} || (); + + my $ret; + my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef; + + my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')'; + my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query); + for (@$args) { + if ($sth->execute(@$_)) { + ++$ret; + } + else { + $self->warn(CANTEXECUTE => $query); + } + } + $self->{dbh}->commit; + $ret; +} + +sub quote { +# ----------------------------------------------------------------------------- +# This subroutines quotes (or not) a value. Postgres can't handle any text +# fields containing null characters, so this has to go beyond the ordinary +# quote() in GT::SQL::Driver by stripping out null characters. +# + my $val = pop; + return 'NULL' if not defined $val; + return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val =~ y/\x00//d; + (values %GT::SQL::Driver::CONN)[0]->quote($val); +} + +package GT::SQL::Driver::PG::sth; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver::sth/; + +sub insert_id { +# ------------------------------------------------------------------- +# Retrieves the current sequence. +# + my $self = shift; + my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i; + $table ||= $self->{name}; + + my $query = "SELECT CURRVAL('${table}_seq')"; + 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; + + return $id; +} + +# ------------------------------------------------------------------------------------------------ # +# DATA TYPE MAPPINGS +# ------------------------------------------------------------------------------------------------ # +package GT::SQL::Driver::PG::Types; +# =============================================================== +use strict; +use GT::SQL::Driver::Types; +use Carp qw/croak/; +use vars qw/@ISA/; +@ISA = 'GT::SQL::Driver::Types'; + +sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') } +sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" } + +# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big) +# caveat to this type, however, is that it requires escaping for any input, and +# unescaping for any output. + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm new file mode 100644 index 0000000..78e8965 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm @@ -0,0 +1,191 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::Types +# CVS Info : 087,071,086,086,085 +# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Implements subroutines for each type to convert into SQL string. +# See GT::SQL::Types for documentation +# +# Supported types are: +# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits +# REAL FLOAT DOUBLE - 32, 32, 64 bits +# DECIMAL - decimal precision +# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc. +# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space +# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type +# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively +# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes +# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons. +# FILE - GT::SQL pseudo-type + +package GT::SQL::Driver::Types; +use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/; +use strict; +use Exporter(); +use GT::Base(); + +*import = \&Exporter::import; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = 'GT::Base'; + +$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/; +@EXPORT_OK = qw/base/; + +sub base { +# ------------------------------------------------------------------ +# Base function takes care of most of the types that don't require +# much special formatting. +# + my ($class, $args, $name, $attribs) = @_; + $attribs ||= []; + my $out = $name; + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + $out; +} + +# Integers. None of the following are supported by Oracle, which can only +# define integer types by the number of digits supported (see +# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by +# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned +# attribute is also passed in). All int types are signed - an 'unsigned' +# column attribute can be used to /suggest/ that the integer type be unsigned - +# but it is only for some databases and/or INT types, and so not guaranteed. +sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int +sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int +sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int +sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int +sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int + +sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above + +# Floating point numbers +sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision) +sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks +sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL + +sub DECIMAL { +# ------------------------------------------------------------------ +# Takes care of DECIMAL's precision. +# + my ($class, $args, $out, $attribs) = @_; + $out ||= 'DECIMAL'; + $attribs ||= []; + + # 'scale' and 'precision' are the proper names, but a prior version used + # the unfortunate 'display' and 'decimal' names, which have no relevant + # meaning in SQL. + my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef; + my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef; + + $scale ||= 0; + $precision ||= 10; + + $out .= "($precision, $scale)"; + + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}); + $args->{not_null} and $out .= ' NOT NULL'; + return $out; +} + +# Dates - just about every database seems to do things differently here. +sub DATE { $_[0]->base($_[1], 'DATE') } +sub DATETIME { $_[0]->base($_[1], 'DATETIME') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') } +sub TIME { $_[0]->base($_[1], 'TIME') } +sub YEAR { $_[0]->base($_[1], 'YEAR') } + +# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255. +# Everything except Oracle handles VARCHAR's - Oracle, having deprecated +# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY' +# attribute to turn this into a "binary" char (meaning, really, +# case-insensitive, not binary) - for everything else, a "binary" argument is +# simply ignored. +sub CHAR { + my ($class, $args, $out) = @_; + # Important the set the size before calling BINARY, because BINARY's + # behaviour is different for sizes <= 255. + $args->{size} = 255 unless $args->{size} and $args->{size} <= 255; + +# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR + $out ||= 'VARCHAR'; + $out .= "($args->{size})"; + + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + return $out; +} +sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') } + +# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to +# provide different types based on the 'size' attribute. +sub TEXT { + my ($class, $attrib) = @_; + $class->base($attrib, 'TEXT') +} + +# .+TEXT is for compatibility with old code, and should be considered +# deprecated. Takes the args hash and the size desired. +sub _OLD_TEXT { + my ($class, $args, $size) = @_; + $args = {$args ? %$args : ()}; + $args->{size} = $size unless $args->{size} and $args->{size} < $size; + $class->TEXT($args); +} +sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) } +sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) } +sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) } +sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) } + +# The BLOB* columns below are heavily deprecated - they're still here just in +# case someone is still using them. Storing binary data inside an SQL row is +# generally a poor idea; a much better approach is to store a pointer to the +# data (such as a filename) in the database, and the actual data in a file. +# +# As such, the default behaviour is to fatal if BLOB's are used - only drivers +# that supported BLOB's prior to protocol v2 should override this. Should a +# binary type be desired in the future, a 'BINARY' pseudo-type is recommended. +sub BLOB { + my ($driver) = $_[0] =~ /([^:]+)$/; + $driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver; + $_[0]->fatal(DRIVERTYPE => $driver => 'BLOB') +} +sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') } +sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') } +sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') } + +# Enums - a non-standard SQL type implemented only by MySQL - the default +# implementation is to implement it as a CHAR (or TEXT if the longest value is +# more than 255 characters - but in that case, are you really sure you want to +# use this type?) +sub ENUM { + my ($class, $args) = @_; + my $max = 0; + @{$args->{'values'}} or return; + for my $val (@{$args->{'values'}}) { + my $len = length $val; + $max = $len if $len > $max; + } + my $meth = $max > 255 ? 'TEXT' : 'CHAR'; + $class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} }); +} + +# File handling +sub FILE { + my ($class, $args) = @_; + $class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} }); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm new file mode 100644 index 0000000..fe2e264 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm @@ -0,0 +1,189 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::debug +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# GT::SQL::Driver debugging module +# + +package GT::SQL::Driver::debug; +use strict; + +use strict; +use GT::AutoLoader; +use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/; +@ISA = qw(GT::Base); +$QUERY_STACK_SIZE = 100; + +$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB'; +sub last_query { +# ------------------------------------------------------------------- +# Get, or set the last query. +# + my $self = shift; + return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug}); + + @_ > 0 or return $LAST_QUERY || ''; + + $LAST_QUERY = shift; + $LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_); + +# Display stack traces if requested via debug level. + my $stack = ''; + if ($self->{_debug} > 2) { + ($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY); + } + elsif ($self->{_debug} > 1) { + package DB; + my $i = 2; + my $ls = defined $ENV{REQUEST_METHOD} ? '
        ' : "\n"; + my $spc = defined $ENV{REQUEST_METHOD} ? ' ' : ' '; + 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; + $stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!; + } + else { + $stack .= qq!$sub called at $file line $line with no arguments.$ls!; + } + } + } + push @QUERY_STACK, $LAST_QUERY; + push @STACK_TRACE, "
        \n" . $stack . "\n
        \n" if ($self->{_debug} and $stack); + +# Pesistance such as Mod_Perl + @QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK; + @STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE; + + return $LAST_QUERY || ''; +} +END_OF_SUB + +$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB'; +sub js_stack { +# ------------------------------------------------------------------- +# Create a nicely formatted javascript browser that (unfortunately) +# only works in ie, netscape sucks. +# + my ($sp, $title) = @_; + + my $nb = @QUERY_STACK; + my ($stack, $dump_out); + { + package DB; + require GT::Dumper; + my $i = 0; + + while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) { + if (@DB::args) { + $args = "with arguments
           "; + my @args; + for (@DB::args) { + eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference + my $print = $@ ? \$_ : $_; + my $arg = defined $print ? $print : '[undef]'; + + $args .= "$arg, "; + my $dump = GT::Dumper::Dumper($arg); + $dump_out .= qq~ + +Top +
        $dump
        + ~; + $i++; + } + chop $args; chop $args; + } + else { + $args = "with no arguments"; + } + $stack .= qq!
      • $sub called at $file line $line $args.
      • \n!; + } + } + $stack =~ s/\\/\\\\/g; + $stack =~ s/[\n\r]+/\\n/g; + $stack =~ s/'/\\'/g; + $stack =~ s,script,sc'+'ript,g; + + $dump_out =~ s/\\/\\\\/g; + $dump_out =~ s/[\n\r]+/\\n/g; + + $dump_out =~ s/'/\\'/g; + $dump_out =~ s,script,sc'+'ript,g; + + my $var = < +function my$nb () { + msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes'); + msg.document.write('STACK TRACE
          $stack
        $dump_out'); + msg.document.close(); +} +HTML + my $link = qq!$title
        !; + + return $var, $link; +} +END_OF_SUB + +$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB'; +sub quick_quote { +# ------------------------------------------------------------------- +# Quick quote to replace ' with \'. +# + my $str = shift; + defined $str and ($str eq "") and return "''"; + $str =~ s/'/\\'/g; + return $str; +} +END_OF_SUB + +$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB'; +sub replace_placeholders { +# ------------------------------------------------------------------- +# Replace question marks with the actual values +# + my ($self, $query, @args) = @_; + if (@args > 0) { + my @vals = split /('(?:[^']+|''|\\')')/, $query; +# Keep track of where we are in each of the @vals strings so that strings with +# '?'s in them that aren't placeholders don't incorrectly get replaced with +# values. + my @vals_idx; + VALUE: for my $val (@args) { + SUBSTRING: for my $i (0 .. $#vals) { + next SUBSTRING if $i % 2; + $vals_idx[$i] ||= 0; + $vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]); + if ($vals_idx[$i] >= 0) { + $val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL'; + substr($vals[$i], $vals_idx[$i], 1, $val); + $vals_idx[$i] += length $val; + next VALUE; + } + else { + $vals_idx[$i] = 0; + } + } + } + $query = join '', @vals; + } + return $query; +} +END_OF_SUB + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm new file mode 100644 index 0000000..b4efbf9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm @@ -0,0 +1,296 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::sth +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# Generic statement handle wrapper +# + +package GT::SQL::Driver::sth; +use strict; +use GT::Base; +use GT::AutoLoader(NEXT => '_AUTOLOAD'); +require GT::SQL::Driver; +use GT::SQL::Driver::debug; +use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE); + +$DEBUG = 0; +@ISA = qw/GT::SQL::Driver::debug/; +$ERROR_MESSAGE = 'GT::SQL'; + +# Get rid of a 'used only once' warnings +$DBI::errstr if 0; + +sub new { +# -------------------------------------------------------- +# Create a new driver sth. +# + my $this = shift; + my $class = ref $this || $this; + my $opts = {}; + my $self = bless {}, $class; + + if (@_ == 1 and ref $_[0]) { $opts = shift } + elsif (@_ and @_ % 2 == 0) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") } + + $self->{_debug} = $opts->{_debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL'; + + # Drivers can set this to handle name case changing for fetchrow_hashref + $self->{hints} = $opts->{hints} || {}; + + for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) { + $self->{$_} = $opts->{$_} if exists $opts->{$_}; + } + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; +} + +$COMPILE{execute} = __LINE__ . <<'END_OF_SUB'; +sub execute { +# -------------------------------------------------------- +# Execute the query. +# + my $self = shift; + my $do = $self->{do}; + my $rc; + +# Debugging, stack trace is printed if debug >= 2. + 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/
        /\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 (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) { + $meth = "_execute_$meth"; + $rc = $self->$meth(@_) or return; + } + else { + $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); + } + + if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) { + my $elapsed = Time::HiRes::time() - $time; + $self->debug(sprintf("Query execution took: %.6fs", $elapsed)); + } + + $rc; +} +END_OF_SUB + +# Define one generic execute, and alias all the specific _execute_* functions to it +sub _generic_execute { + my $self = shift; + $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); +} +for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) { + $_ = \&_generic_execute; +} + +sub rows { + my $self = shift; + return $self->{_rows} if exists $self->{_rows}; + return $self->{rows} if exists $self->{rows}; + $self->{sth}->rows; +} + +sub fetchrow_arrayref { +# ----------------------------------------------------------------------------- + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_arrayref; + return shift @{$self->{_results}}; +} + +sub fetchrow_array { +# ----------------------------------------------------------------------------- +# When called in scalar context, returns either the first or last row, as per +# DBI, so avoid using in scalar context when fetching more than one row. +# + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_array; + my $arr = shift @{$self->{_results}}; + return $arr ? wantarray ? @$arr : $arr->[0] : (); +} + +# ----------------------------------------------------------------------------- +# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's +# documentation no longer mentions it at all). +*fetchrow = \&fetchrow_array; *fetchrow if 0; + +sub fetchrow_hashref { +# ----------------------------------------------------------------------------- + my $self = shift; + return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results}; + $self->{sth}->fetchrow_hashref; +} + +$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _fetchrow_hashref { +# ----------------------------------------------------------------------------- +# Handles row fetching for driver that can't use the default ->fetchrow_hashref +# due to needing column case mapping ($sth->{hints}->{case_map}), or special +# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit +# handling). +# + my $self = shift; + + my %case_map; # returnedname => ReturnedName, but only for columns that use upper case + if ($self->{hints}->{case_map}) { + if (exists $self->{schema}->{cols}) { + my $cols = $self->{schema}->{cols}; + %case_map = map { lc $_ => $_ } keys %$cols; + } + else { + for my $table (keys %{$self->{schema}}) { + for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) { + $case_map{lc $col} = $col; + } + } + } + } + + if ($self->{_results}) { + my $arr = shift @{$self->{_results}} or return; + + my $i; + my %selected = map { lc $_ => $i++ } @{$self->{_names}}; + my %hash; + + for my $lc_col (keys %selected) { + if (exists $case_map{$lc_col}) { + $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}]; + } + else { + $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}]; + } + } + return \%hash; + } + else { + my $h = $self->{sth}->fetchrow_hashref or return; + for (keys %$h) { + $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_}; + } + return $h; + } +} +END_OF_SUB + +sub fetchall_arrayref { +# --------------------------------------------------------------- + my $self = shift; + return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results}; + + my $opt = shift; + if ($opt and ref $opt eq 'HASH') { + my @ret; + while (my $row = $self->fetchrow_hashref) { + for (keys %$row) { + delete $row->{$_} unless exists $opt->{$_}; + } + push @ret, $row; + } + return \@ret; + } + + my $results = $self->{_results}; + $self->{_results} = []; + return $results; +} + +sub fetchall_list { map @$_, @{shift->fetchall_arrayref} } + +sub fetchall_hashref { +# ----------------------------------------------------------------------------- +# This is very different from DBI's fetchall_hashref - this is actually +# equivelant to DBI's ->fetchall_arrayref({}) +# + my $self = shift; + my @results; + while (my $hash = $self->fetchrow_hashref) { + push @results, $hash; + } + return \@results; +} + +sub row_names { + my $self = shift; + $self->{_names} || $self->{sth}->{NAME}; +} + +$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB'; +sub insert_id { +# ------------------------------------------------------------------- +# Returns the value of the last record inserted. +# + return $_[0]->{sth}->{insertid}; +} +END_OF_SUB + +sub DESTROY { +# ------------------------------------------------------------------- +# Calls finish on the row when it is destroyed. +# + my $self = shift; + $self->debug("OBJECT DESTROYED") if $self->{_debug} > 2; + $self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish"); +} + +sub _AUTOLOAD { +# ------------------------------------------------------------------- +# Autoloads any unknown methods to the DBI::st object. +# + my ($self, @param) = @_; + my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/; + + if (exists $DBI::st::{$attrib}) { + local *code = $DBI::st::{$attrib}; + if (*code{CODE}) { + $self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1; + return code($self->{sth}, @param); + } + } + + $GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD; + goto >::SQL::Driver::debug::AUTOLOAD; +} + +sub debug { +# ------------------------------------------------------------------- +# DBI::st has a debug that autoload is catching. +# + my $self = shift; + my $i = 1; + my ($package, $file, $line, $sub); + while (($package, $file, $line) = caller($i++)) { + last if index($package, 'GT::SQL') != 0; + } + while ($sub = (caller($i++))[3]) { + last if index($sub, 'GT::SQL') != 0; + } + my $msg = $_[0]; + $msg .= " from $sub" if $sub; + $msg .= " at $file" if $file; + $msg .= " line $line" if $line; + $msg .= "\n"; + return $self->SUPER::debug($msg); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Editor.pm new file mode 100644 index 0000000..b5aabc9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Editor.pm @@ -0,0 +1,1082 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# CVS Info : 087,071,086,086,085 +# $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Editor; +# ================================================================== +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERRORS $error $ERROR_MESSAGE/; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.79 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw(GT::SQL::Base); +$DEBUG = 0; + +sub new { + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)"); + + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). 'table' must be specified in the hash. It needs to be the an object from GT::SQL::Table."); + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + +# We almost always need to be connected. + $self->{table}->connect or return; + return $self; +} + + +################################################################# +##### Editing functions ##### +################################################################# +## +# $obj->add_col($col_name, +# { +# size => 20, +# type => 'int', +# view_size => 20, +# form_display => "my col", +# regex => 'myregex' +# } +# ); +# ------------------------------------ +# +## +$COMPILE{add_col} = __LINE__ . <<'END_OF_SUB'; +sub add_col { + my ($self, $name, $col) = @_; + + $name and ref $col eq 'HASH' or return $self->fatal(BADARGS => '$obj->add_col(COLUMN_NAME, HASH_REF)'); + my $c = $self->{table}->cols; + + # Check the database instead of the def file so that we don't end up with + # an inability to add a column when the database and def files are out of + # sync. + my $exists = $self->{table}->{driver}->column_exists($self->{table}->name, $name); + $exists and return $self->warn(COLEXISTS => $name); + +# You are not permitted to add a not_null column without a default to a table - +# the default is required for existing columns. You could, if you really want +# it with no default, create it with a default, then alter it to drop the +# default. + return $self->warn(NOTNULLDEFAULT => $name) + if $col->{not_null} and (not defined $col->{default} or $col->{default} eq ''); + +# count file columns + my %fcols_initial = $self->{table}->_file_cols(); + +# handle the search indexes + my $tmp_weight = {}; + $tmp_weight = $self->_get_indexer()->pre_add_column($name, $col) or return if $col->{weight}; + +# get the column definition + my $col_props = $self->{table}->{driver}->column_sql($col); + my $table = $self->{table}->name; + +# Auto add a new position number. + $col->{pos} = keys(%$c) + 1; + +# Add the column into the table's column hash, for checking. +# N.B. - everything below this point _must_ reload the table information (i.e. +# via ->reset or ->reload) upon failure + $c->{$name} = $col; + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + + require GT::SQL::Creator; + GT::SQL::Creator::set_defaults($self, { $name => $col }); + +# Make the changes + $self->{table}->{driver}->add_column($table, $name, $col_props) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + +# Check for file columns + if (not keys %fcols_initial and uc $col->{form_type} eq 'FILE') { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + $self->{table}->_file_cols(1); + } + +# finish off the search indexes + if ($col->{weight}) { + $self->_get_indexer()->post_add_column($name, $col, $tmp_weight) or return; + } + + 1; +} +END_OF_SUB + +## +# $obj->drop_col($col_name); +# --------------------------- +# Drops the column specified by $col_name. +# If the column is referenced returns an error. +# If the column is itself an fk reference, the foreign key is dropped. +# +# $obj->drop_col($col_name, "remove"); +# ------------------------------------- +# Drops column and all fk references to it. +# +## +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { + my $self = shift; + my $name = shift || return $self->fatal(BADARGS => '$obj->drop_col(COLUMN_NAME,[ STRING ])'); + exists $self->{table}->cols->{$name} or return $self->warn(NOCOL => $name); + my $kill = shift; + + my %fcols = $self->{table}->_file_cols(); + my $table = $self->{table}->name; + if ($self->_is_referenced($table, $name)) { + if (defined $kill) { + $self->_remove_references($table, $name); + } + else { + return $self->warn(REFCOL => $name, $table); + } + } + + my @fk_tables = grep exists $self->{table}->{fk}->{$_}->{$name}, keys %{$self->{table}->{fk}}; + if (@fk_tables) { + $self->drop_fk($_, 1); + } + + my $tmp_weight = {}; + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->_get_indexer()->pre_delete_column($name, $self->{table}->cols->{$name}) or return + } + +# Columns + my $old_col = delete $self->{table}->cols->{$name}; + +# Primary key + $self->{table}->pk(grep $_ ne $name, $self->{table}->pk); + +# Foreign keys + while (my ($table, $fk) = each %{$self->{table}->fk}) { + for my $col (keys %$fk) { + if ($col eq $name) { + delete $self->{table}->fk->{$_}->{$col} + } + } + } + +# Indexes and uniques + for my $index (qw/index unique/) { + my $ndx = $self->{table}->$index(); + for (keys %$ndx) { + my @new = grep $_ ne $name, @{$ndx->{$_}}; + if (@new) { + $ndx->{$_} = \@new; + } + else { + delete $ndx->{$_}; + } + } + } + +# Update the positions. + my $cols = $self->{table}->cols; + my $i; + for my $col (sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols) { + $cols->{$col}->{pos} = ++$i; + } + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + +# File Handling + if ($fcols{$name}) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->drop_col($name, $fcols{$name}->{file_save_scheme}) or return $self->{table}->reset; + $self->{table}->_file_cols(1); + } + +# Finish off the index table stuff + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->post_delete_column($name, $self->{table}->cols->{$name}, $tmp_weight) + or return $self->{table}->reset; + } + +# Make the changes - actually drop the column + $self->{table}->{driver}->drop_column($table, $name, $old_col) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + + 1; +} +END_OF_SUB + +## +# $obj->alter_col($column_name, \%new_defs); +# ------------------------------------------- +# +$COMPILE{alter_col} = __LINE__ . <<'END_OF_SUB'; +sub alter_col { + my ($self, $col, $defs) = @_; + + ref $defs eq 'HASH' or return $self->fatal(BADARGS => '$obj->alter_col(COLUMN_NAME, HASH_REF)'); + exists $self->{table}->{schema}->{cols}->{$col} or return $self->warn(NOCOL => $col); + + my %fcols = $self->{table}->_file_cols(); + +# Can't change the position, force it to what it was before. + my $orig = $self->{table}->{schema}->{cols}->{$col}; + my $table = $self->{table}->{name}; + +# Set the position, can't be changed. + $defs->{pos} = $orig->{pos}; + +# Check to see if we need to update the SQL. + my $orig_sql = $self->{table}->{driver}->column_sql($orig); + my $new_sql = $self->{table}->{driver}->column_sql($defs); + my $change = $orig_sql ne $new_sql; + +# If we've changed, check the keys. + if ($change) { + return $self->warn(REFCOL => $col, $table) if $self->_is_referenced($table, $col); + return $self->warn(COLREF => $col, $table) if exists $self->{table}->fk->{$col}; + } + +# Check for conflicts + my $old_col = $self->{table}->{schema}->{cols}->{$col}; + $self->{table}->{schema}->{cols}->{$col} = $defs; + $self->{table}->check_schema or return $self->{table}->reset; + +# adding a file column + if (not keys %fcols and $defs->{form_type} and lc $defs->{form_type} eq 'file') { + + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->debug_level($self->{_debug}); + $ftable->install({parent_tablename => $self->{table}->name() }); + } + +# removing a file column + elsif ($fcols{$col} and not ($defs->{form_type} and lc $defs->{form_type} eq 'file')) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->drop_col($col); + } + +# Make the changes + if ($change) { + $self->{table}->{driver}->alter_column($table, $col, $new_sql, $old_col) or return $self->{table}->reset; + } + $self->{mods}->{$table} = $self->{table}; + $self->save_state or return; + +# finish off the file column setup + if ($defs->{form_type} and lc $defs->{form_type} eq 'file') { + $self->{table}->update({ $col => '' }); + $self->{table}->_file_cols(1); + } + + 1; +} +END_OF_SUB + +## +# $obj->add_index($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_index} = __LINE__ . <<'END_OF_SUB'; +sub add_index { + my ($self, $index_name, $columns) = @_; + ref $columns eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_index(INDEX_NAME => ARRAY_REF)'); + +# Do the columns exist? + for (@$columns) { + return $self->warn(NOCOL => $_) unless exists $self->{table}->cols->{$_}; + } + + exists $self->{table}->{schema}->{index}->{$index_name} + and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + $self->{table}->{schema}->{index}->{$index_name} = $columns; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_index($table, $index_name, @$columns) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_index($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB'; +sub drop_index { + my ($self, $index_name) = @_; + $index_name or return $self->fatal(BADARGS => '$obj->drop_index(INDEX_NAME)'); + exists $self->{table}->index->{$index_name} or return $self->warn(NOINDEX => $index_name); + +# Check for conflicts + delete $self->{table}->index->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_unique($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a unique index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_unique} = __LINE__ . <<'END_OF_SUB'; +sub add_unique { + my ($self, $index_name, $indexes) = @_; + + $index_name and ref $indexes eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_unique(INDEX_NAME => ARRAY_REF)'); +# Do the columns exist? + for (@$indexes) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + exists $self->{table}->unique->{$index_name} and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Do the new fields have unique data in them? + my $in = join ", " => @{$indexes}; + my $query = "SELECT $in, COUNT(*) AS hits FROM $table GROUP BY $in HAVING "; + $query .= lc $self->{table}->{connect}->{driver} eq 'mysql' ? 'hits' : 'COUNT(*)'; + $query .= ' > 1'; + $self->debug($query) if $self->{_debug}; + + my $sth = $self->{table}->do($query) or return; + $sth->fetchrow and return $self->warn(NOTUNIQUE => $index_name); + +# Check for conflicts + $self->{table}->unique->{$index_name} = $indexes; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_unique($table, $index_name, @$indexes) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_unique($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_unique} = __LINE__ . <<'END_OF_SUB'; +sub drop_unique { + my ($self, $index_name) = @_; + + $index_name or return $self->fatal(BADARGS => '$obj->drop_unique(INDEX_NAME)'); + exists $self->{table}->unique->{$index_name} or return $self->warn(NOUNIQUE => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + delete $self->{table}->unique->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_pk($field1, $field2, ...); +# ------------------------------------- +# Addes primary keys specified by list. If there is already a primary key it +# drops it and adds all the keys at the same time. If there is no primary +# keys this makes sure the data in the primary keys is unique. +## +$COMPILE{add_pk} = __LINE__ . <<'END_OF_SUB'; +sub add_pk { + my ($self, @fields) = @_; + + @fields or return $self->fatal(BADARGS => '$obj->add_pk(COLUMN1, COLUMN2, ...)'); + for (@fields) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + + my ($table, %add) = $self->{table}->name; + if ($self->{table}->pk) { + $self->{table}->{driver}->drop_pk($table) or return; + %add = map { $_ => 1 } @{delete $self->{table}->{schema}->{pk}}; + } + +# Check for conflicts + for (@fields) { $add{$_} = 1 } + $self->{table}->{schema}->{pk} = [keys %add]; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_pk($table, keys %add) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_pk; +# -------------- +# Drops the current primary key. +## +$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB'; +sub drop_pk { + my $self = shift; + $self->{table}->pk or return $self->warn('NOPK'); + +# Check for conflicts + $self->{table}->{schema}->{pk} = []; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_pk($table) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_fk( RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +$COMPILE{add_fk} = __LINE__ . <<'END_OF_SUB'; +sub add_fk { + my $self = shift; + $self->{table}->fk(@_) or return; + 1; +} +END_OF_SUB + +## +# $obj->drop_fk(RELATION_NAME [, SKIPSAVE]); +# --------------------------------------------- +# Drops the foreign key relation for a given relation. If a second parameter +# is passed, and true, the state of the current table will not be saved (any +# other changed tables are, however). +## +$COMPILE{drop_fk} = __LINE__ . <<'END_OF_SUB'; +sub drop_fk { + my ($self, $tbl, $nosave) = @_; + my $table = $self->{connect}->{PREFIX} . $tbl; + delete $self->{table}->{schema}->{fk}->{$table} + or return $self->warn(FKNOEXISTS => $tbl, $self->{table}->{name}); + my $remote = $self->new_table($table); + my $rfk = $remote->fk_tables || []; + $remote->fk_tables([grep $_ ne $self->{table}->{name}, @$rfk]); + $remote->save_state; + $self->{table}->save_state unless $nosave; +} +END_OF_SUB + +## +# $obj->add_tree(ARGS); +# --------------------- +# Create a tree table for the current table. +# 'ARGS' is a hash or hash reference consisting of the following: +# father => 'father_id_column', +# root => 'root_id_column', +# depth => 'depth_column' +# where 'father_id_column', 'root_id_column', and 'depth_column' are the names +# of the columns you will use for keeping track of the father record, root +# record, and the depth from the root record, respectively. All of these +# columns should already exist - an error will occur if they do not. +# +# Any other arguments passed in will be passed straight through to +# GT::SQL::Tree->create +## +$COMPILE{add_tree} = __LINE__ . <<'END_OF_SUB'; +sub add_tree { + my $self = shift; + + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(HASH or HASH REF)'); + + return $self->warn(TREEEXISTS => $self->{table}->{name}) if $self->{table}->{schema}->{tree} and ($input->{force} || 'force') eq 'check'; + + $input->{father} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., father => \'father_col\', ...)'); + $input->{root} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., depth => \'depth_col\', ...)'); + + require GT::SQL::Tree; + GT::SQL::Tree->create(debug => $self->{_debug}, %$input, table => $self->{table}); +} +END_OF_SUB + +$COMPILE{drop_tree} = __LINE__ . <<'END_OF_SUB'; +sub drop_tree { + my $self = shift; + my $tree = $self->{table}->tree or return; + $tree->destroy; +} +END_OF_SUB + +$COMPILE{load_data} = __LINE__ . <<'END_OF_SUB'; +sub load_data { +# --------------------------------------------------------------- +# imports the contents of a file with validation. +# + my ($self, $file, $options) = @_; + -f $file and -r _ or return $self->fatal(FILENOEXISTS => $file); + $self->{table}->connect or return; + + my $delim = $options->{delim} || '|'; + my @cols = ref $options->{cols} ? @{$options->{cols}} : @{$self->{table}->ordered_columns}; + + local *FILE; + open FILE, $file or return $self->warn(CANTOPEN => $file, "$!"); + while () { + chomp; + my $i = 0; + my %fields = map { $cols[$i++] => $_ } split /(?{table}->insert(\%fields, 1) or print "Line $. skipped - validation failed:\n$GT::SQL::error\n\n"; + } + close FILE; + 1; +} +END_OF_SUB + +$COMPILE{export_data} = __LINE__ . <<'END_OF_SUB'; +sub export_data { +# --------------------------------------------------------------- +# Dumps the contents of a table to a file. +# + my $self = shift; + my $opt = shift; + ref $opt eq 'HASH' or return $self->fatal(BADARGS => '$obj->export_data(HASHREF)'); + + my $order = $opt->{order}; + my $delim = $opt->{delim} || '|'; + my $file = $opt->{file} || undef; + my $header = $opt->{header} || undef; + my $table = $self->{table}->name; + + my @order = $order + ? ref $order eq 'ARRAY' ? @$order : $order + : $self->{table}->ordered_columns; + + my ($offset, $limit) = (0, 1000); + + local *FILE; + if ($file) { + open FILE, "> $file" or return $self->warn(CANTOPEN => $file, "$!"); + } + while () { + $self->{table}->select_options("LIMIT $limit OFFSET " . ($offset++ * $limit)); + my $sth = $self->{table}->select(\@order); + + if ($header) { + print FILE join($delim, @order), "\n"; + $header = undef; + } + my $count = 0; + while (my $arr = $sth->fetchrow_arrayref) { + ++$count; + for (@$arr) { + y/\r//d; + s/\Q$delim\E/``/g; + s/\n/~~/g; + } + my $joined = join $delim, @$arr; + $file + ? print FILE $joined, "\n" + : print $joined, "\n"; + } + last unless $count; + } + 1; +} +END_OF_SUB + +## +# $obj->drop_search_driver +# ----------------- +# Drops current search driver +## +$COMPILE{drop_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub drop_search_driver { + my $self = shift; + + require GT::SQL::Search; + if ($self->{table}->search_driver) { + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}) or return; + $indexer->drop_search_driver or return; + } + $self->{table}->search_driver('NONINDEXED'); + $self->{table}->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{add_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub add_search_driver { + my $self = shift; + my $olddriver = $self->{table}->search_driver(); + my $newdriver = shift or return; + + require GT::SQL::Search; + +# check and see if driver is ok + GT::SQL::Search->driver_ok($newdriver, { table => $self->{table} }) or return; + +# load the driver + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}, driver => $newdriver) or return; + $indexer->add_search_driver or return; + + $self->{table}->search_driver($newdriver); + $self->{table}->save_state or return; + 1; +} +END_OF_SUB + +## +# $obj->change_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{change_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub change_search_driver { + my $self = shift; + my $newdriver = uc shift or return; + my $driver = $self->{table}->search_driver; + $driver eq $newdriver and return $self->warn(SAMEDRIVER => $driver); + + $self->drop_search_driver() or return; + $self->add_search_driver($newdriver) or return; + + 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + my $rm_fk = lc(shift or '') eq 'remove'; + my $table = $self->{table}->name; + my $tmp = $self->{table}->fk_tables() || []; + @$tmp and !$rm_fk and return $self->warn(TABLEREFD => $table); + + my $tmp_weights = {}; + if ($self->_uses_weights) { + $tmp_weights = $self->_get_indexer->pre_drop_table() or return + } + + $self->{table}->{driver}->drop_table($table) or return; + + delete $GT::SQL::OBJ_CACHE{"TABLE\0$table\0$self->{connect}->{def_path}"}; + +# If this table has a tree, drop it: + $self->drop_tree if $self->{table}->{schema}->{tree}; + + unlink "$self->{connect}->{def_path}/$table.def"; + + for (keys %{$self->{table}->{schema}->{fk}}) { + next if $_ eq $table; + my $t = $self->new_table($_); + $t->{schema}->{fk_tables} = [grep $_ ne $table, @{$t->{schema}->{fk_tables}}]; + $t->save_state(); + } + + $self->_file_drop_tables(); + $self->_uses_weights and ($self->_get_indexer->post_drop_table($tmp_weights) or return); + $rm_fk and $self->_drop_related_fk_entries($table); + + 1; +} +END_OF_SUB + +$COMPILE{_file_drop_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_drop_tables { + my $self = shift; + if ( $self->{table}->_file_cols() ) { + require GT::SQL::File; + GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} })->drop_table(); + } +} +END_OF_SUB + +$COMPILE{_drop_related_fk_entries} = __LINE__ . <<'END_OF_SUB'; +sub _drop_related_fk_entries { + my $self = shift; + my $table_name = shift or return; + + my $fk = $self->{table}->fk() or return; + my $prefix = $self->{connect}->{PREFIX}; + for my $related_name ( keys %{$fk} ) { + my $table = $self->{table}->new_table($related_name); + my $fk_tables = $table->fk_tables() or next; + $fk_tables = [ grep { $_ ne $table_name } @{$fk_tables} ]; + $table->fk_tables( $fk_tables ); + $table->save_state(); + } + + 1; +} +END_OF_SUB + +########################################################################### +##### Private Functions ##### +########################################################################### + +$COMPILE{_is_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _is_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $fk = $self->new_table($table)->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + return 1; + } + } + } + } + 0; +} +END_OF_SUB + +$COMPILE{_remove_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _remove_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $new_table = $self->{mods}->{$table} || $self->new_table($table); + my $fk = $new_table->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + delete $fk->{$mytable}->{$key}; + $self->{mods}->{$table} ||= $new_table; + } + if (not keys %{$fk->{$mytable}}) { + delete $fk->{$mytable}; + $self->{mods}->{$table} ||= $new_table; + } + } + } + } + 1; +} +END_OF_SUB + +$COMPILE{_remove_references} = __LINE__ . <<'END_OF_SUB'; +sub _remove_references { + my ($self, $mytable, $mycol) = @_; + for my $table (keys %{$self->{table}->fk}) { + if ($self->{table}->fk->{$table}->{$mycol}) { + delete $self->{table}->fk->{$table}->{$mycol}; + } + next if keys %{$self->{table}->fk->{$table}}; + my $t = $self->{mods}->{$table} || $self->new_table($table); + $t->{schema}->{fk_table} = [grep $_ ne $mytable, @{$t->fk_tables}]; + $self->{mods}->{$table} = $t; + } + 1; +} +END_OF_SUB + +sub save_state { + my $self = shift; + for my $table (keys %{$self->{mods}}) { + my $new_table = $self->{mods}->{$table}; + $new_table->save_state or return; + delete $self->{mods}->{$new_table}; + } + 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Editor - an interface to modify an SQL table. + +=head1 SYNOPSIS + + my $editor = $DB->editor('Table'); + $editor->add_col(Foo => { size => 20, type => 'int' }); + $editor->export_data('/tmp/foo.txt'); + +=head1 DESCRIPTION + +GT::SQL::Editor is an easy way to do a lot of table maintenance +functions like: + +* Adding columns +* Dropping columns +* Changing columns +* Altering keys +* Importing data +* Dropping data + +To get an editor object, you simply call C from a +GT::SQL object, and specify the tablename you want to edit: + + $editor = $db->editor('TableName'); + +Note: You can not use Editor with relations, only tables. + +=head2 add_col + +This method allows you to add a column to the current table. +All attributes for the column are passed in a single hash. + + $editor->add_col($col_name, + { + size => 20, + type => 'int', + view_size => 20, + form_display => "my col", + regex => 'myregex' + } + ); + +The same rules apply to this method that apply when you +define a column for creating a table. You must specify the +type. + +=head2 drop_col + +This method drops a column from the current table. Checks +are made to ensure the column is not linked to by a foreign +key relation. + + $editor->drop_col($col_name); + +-or- + + $editor->drop_col($col_name, "remove"); + +If you just specify the column name C will check if +the column is referenced in a foreign key relation. If it +is C will return undef and set the error message in +$GT::SQL::error. If it is not the column will be dropped. + +If you specify "remove" C will remove all foreign +key relations that point to the specified column. + +If the specified column is itself a foreign key relation, the relation will be +dropped. + +=head2 alter_col + +This allows you to make changes to a columns type, null status, +etc.. + + $editor->alter_col($column_name, + { + size => 20, + type => 'int' + }); + +The first argument is the column name the second is the definitions. +The column definitions are exactly the same as the column +definitions from the create. The type must be specified. + +You can not add attributes to the column in this way. +You must specify the original definitions along with the +changes you need to make. + +=head2 add_unique + +This allows you to add a unique index to the current table. +If the name of the unique index is the same as another +index you C will return undef and set the error +in $GT::SQL::error. + + $editor->add_unique($index_name => [ $field1, $field2 .. ]); + +The name of the new index is the first argument. The second argument +is an array reference containing the columns that will be indexed. +The order of the columns are maintained for the unique index. +If you specify an index that has data in it that is not unique +(yes we do a select on the database) C will return +an error and set the error in $GT::SQL::error. + +=head2 drop_unique + +This method allows you to drop a unique index for the current +table. If the unique index does not exist C will +return undef and set the error in $GT::SQL::error. C +will also check to make sure dropping the unique index will not +cause problems for the database structure. If dropping the unique +index will cause a problem C will return undef and set +the error in $GT::SQL::error. + + $editor->drop_unique($index_name); + +$index_name should be the name of the unique index to drop. + +=head2 add_index + +This takes the same arguments as C and return the same thing. +The only difference is C has no reason to check the content of +the current table because indexes are not unique. unique indexes are :) + + $editor->add_index($index_name => [ $field1, $field2 .. ]); + +=head2 drop_index + +This method drops the specified index from the current table. +C will check to make sure no problems are caused from +dropping the index. If there are C will return undef +and set the error in $GT::SQL::error. + + $editor->drop_index($index_name); + +$index_name should be the name of the index to drop. + +=head2 add_pk + +This method allows you to add a primary key to the current +database. + + $editor->add_pk($field1, $field2, ...); + +If there is already a primary key in the database C +will drop the key and add the this new one. The table +will be check to make sure this change does not create problems +for the table. I problem is auto increment not being the primary +key anymore. If there is a problem this function returns undef +and stores the error in $GT::SQL::error. + +=head2 drop_pk + +This method drops the current primary key. If there is no primary +key to drop it returns undef and sets the error in $GT::SQL::error. + + $editor->drop_pk; + +If dropping the primary key will cause problems for the database +this method will return undef and set the error in $GT::SQL::error. + +=head2 add_fk + +This method allows you to add foreign key relations to the current +table. + + $editor->add_fk($RELATION_NAME, { $SOURCE_FIELD_1 => $TARGET_FIELD }); + +You can not link your foreign key to tables that do not exist. Also the +columns types and lengths for the two columns must be the same. +Circularity is not allowed either. That is a set of foreign keys can not +end up pointing back at the same table they started at. All of these things +are checked when this is added. If anything does not match this method returns +undef and sets the error in $GT::SQL::error. + +=head2 drop_fk + +This method drops the specified foreign key relation. + + $editor->drop_fk($table); + +$table should be the name of the foreign table the foreign +key points to. + +=head2 drop_table + +This method drops the current table. If there are any foreign keys +pointing to this table this method will fail and return undef. The error +will be set in $GT::SQL::error. + + $editor->drop_table; + +-or- + + $editor->drop_table("remove"); + +If the first argument to this method is remove it will remove all +the foreign key relations that point to this table. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/File.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/File.pm new file mode 100644 index 0000000..ebf9e9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/File.pm @@ -0,0 +1,1132 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::File +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# + +package GT::SQL::File; + +use strict; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; +use GT::Base; +use vars qw/@ISA $ERRORS $ATTRIBS $LOG $ERROR_MESSAGE $PERMIT_REFS $DEBUG/; +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$ATTRIBS = { + db => undef, + connect => undef, + def_path => undef, + table_name => '', + table_object => undef, + parent_table => undef, + parent_table_name => undef, + file_save_in => '', + file_log_path => '', + file_name => '', + file_path => '', + file_fpath => '', + + File_Name => '', + ID => '', + ForeignColName => '', + ForeignColKey => '', + File_Name => '', + File_Directory => '', + File_MimeType => '', + File_Size => '', + File_RelativePath => '', + File_Binary => undef, + File_URL => '', + File_RelativeURL => '', + + file_handle => undef, +}; + +# this allows calls to the individual attribs through GT::SQL::File::Fh method +$PERMIT_REFS = { map { $_ => 1 } keys %$ATTRIBS }; +$LOG = { + ADDED => q~Added file %s to %s~, + REPLACE => q~Replaced file %s to %s~, + REMOVED => q~Deleted file %s~, + CREATEDDIR => q~Created directory %s~ +}; + +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + FILE_PARENTTBL => q~Cannot load parent table! (%s)~, + FILE_FILETBL => q~Cannot load file table! (%s)~, + FILE_NOGLOBREF => q~Need a file glob reference in (%s)~, + FILE_FILETOOBIG => q~File %s (%i bytes) exceeds maximum file size (%i bytes)~, + FILE_NOOPEN => q~Problems opening %s for writing: %s~, + FILE_NOBINMODE => q~Could not set %s to binmode: %s~, + FILE_NOCLOSE => q~Had problems closing file %s: %s~, + FILE_NOFILE => q~Could not find file related by ForeignColName => %s, ForeignColKey => %s: %s~, + FILE_FDELETE => q~Problems deleting file %s: %s~, + FILE_NOUNLINK => q~Could not unlink file %s: %s~, + FILE_PKREQ => q~Primary Key required~, + FILE_PKSINGLE => q~Composite Primary Keys not supported~, + FILE_DBDELETE => q~Problems deleting record: %s~, + FILE_DBDELETEALL => q~Problems deleting all records~, + FILE_DBSELECT => q~Problems selecting %s~, + FILE_NOREC => q~Could not find file record~, + FILE_DBDROP => q~Could not drop table %s: %s~, + FILE_DBEDITOR => q~Could not get editor object for table %s: %s~, + FILE_DBUPDATE => q~Problems updating record: %s~, + FILE_DBADD => q~Problems adding record: %s~, + FILE_ILLEGALCHAR => q~Illegal character found in %s~, + FILE_NOOPEN => q~Could not open %s because %s~, + FILE_NOWRITE => q~Could not write data into %s because %s~, + FILE_MKDIRFAIL => q~Couldn't create directory %s, because %s~, + FILE_UNKNOWNREF => q~Reference call '%s' does not refer to a method in GT::SQL::File or an allowed attribute.~, + FILE_NOTNULL => q~A file must be uploaded for the %s column~, + FILE_NULLDELETE => q~Cannot delete file, as a file is required for the %s column~, + FILE_NULLUPDATE => q~A file must be uploaded for the %s column~, +}; + +@$GT::SQL::ERRORS{keys %$ERRORS} = values %$ERRORS; + +use constant ENCODE => 1; + +$COMPILE{rescan} = __LINE__ . <<'END_OF_SUB'; +sub rescan { +#------------------------------------------------------------------------------- +# $obj->rescan(); +#---------- +# Rebuilds the database and attempts to ensure that database records are +# correct. This does not update the parent tables +# + my ($self) = @_; + + my %errs = (); + my %mods = (); + my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error); + my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error); + my %fcols = $ptbl->_file_cols(); + my $sth = $tbl->select() or return $self->error('FILE_DBSELECT', 'WARN', $GT::SQL::error); + while (my $href = $sth->fetchrow_hashref()) { + my $fpath = $self->_file_full_path($href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE); + +# does this file still exist? + if (! -e $fpath) { + $errs{$href->{ID}} = "NOFILE"; + $self->error('FILE_NOFILE', 'WARN', $href->{ForeignColName}, $href->{ForeignColKey}, "FILENOEXIST"); + $tbl->delete({ ForeignColName => $href->{ForeignColName}, ForeignColKey => "$href->{ForeignColKey}" }); + } + +# is it still the same file size? + elsif (-s _ != $href->{File_Size}) { + $mods{$href->{ID}} = "NEWSIZE"; + $href->{File_Size} = -s _; + $tbl->modify($href) or $errs{$href->{ID}} = "CANTMODIFY"; + } + } + + return \%errs, \%mods; +} +END_OF_SUB + +$COMPILE{log} = __LINE__ . <<'END_OF_SUB'; +sub log { +#------------------------------------------------------------------------------- +# $obj->log( $code, LIST ); +#---------- +# puts a log message into the logs file if the path has been set +# + my $self = shift; + my $code = shift; + my $logpath = $self->{file_log_path} or return; + + $self->_check_file_chars( $logpath ) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $logpath ); + CORE::open( LOG, ">>$logpath" ); + print LOG sprintf($LOG->{$code}, @_); + close( LOG ); +} +END_OF_SUB + +$COMPILE{add_file} = __LINE__ . <<'END_OF_SUB'; +sub add_file { +#------------------------------------------------------------------------------- +# $obj->addfile( $new_record, $new_record_id ) +#---------- +# puts a file away into the database +# + my ($self, $rec, $recid ) = @_; + return $self->replace_file( $rec, $recid ); +} +END_OF_SUB + +$COMPILE{replace_file} = __LINE__ . <<'END_OF_SUB'; +sub replace_file { +# -------------------------------------------------------------------------------------- +# $obj->replace_file( $new_record, $new_record_id ) +#---------- +# puts a file away into the database, if a file already exists in place, delete it +# + my ($self, $rec, $recid ) = @_; + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $fcols = { $ptable->_file_cols() }; + my $ftable = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + + foreach my $col_name ( keys %$fcols ) { + +# basic tests + my $col = $fcols->{$col_name}; + my $ref = ref $rec->{$col_name}; + my $fh = ( ( $ref and $ref !~ /SCALAR|ARRAY|HASH/ ) ? $rec->{$col_name} : $self->get_fh( $col_name, $rec ) ) or next; + $col->{file_max_size} and ( ( -s $fh ) <= $col->{file_max_size} or return $self->error( 'FILE_FILETOOBIG', 'WARN', "$fh", -s $fh, $col->{file_max_size} ) ); + +# now, delete the previous entry + if ( $ftable->count({ ForeignColName => $col_name, ForeignColKey => "$recid" }) ) { + ref $fh or $rec->{$col_name."_del"} and $self->delete_file( $col_name, $recid, $col->{file_save_scheme} ); + } + +# find out if we're simply going to skip the action here + not ref $fh and not $fh eq 'delete' and next; + +# get basic information setup + my @paths = split m.(/|\\)., "$fh"; #/\ + my $fname = $rec->{$col_name."_filename"} || pop @paths; + my $fdir = $col->{file_save_in}; + +# now that we have saved the information, add the record to the database + my $new_rec = $self->_file_getstats( $fname, $fdir, $col->{file_save_url}, -s $fh ); + + $new_rec->{ForeignColName} = $col_name; + $new_rec->{ForeignColKey} = $recid; + my $fid = $ftable->add($new_rec) or return $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ); + +# now try to save + my $fpath = $self->_file_full_path( $fname, $fdir, $fid, $col_name, $col->{file_save_scheme}, ENCODE ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + while (read($fh, my $buf, 512 * 1024)) { + print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ); + } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + + $self->log( 'ADDED', $fname, $fdir ); + + } + + return 1; +} +END_OF_SUB + +$COMPILE{delete_file} = __LINE__ . <<'END_OF_SUB'; +sub delete_file { +# -------------------------------------------------------------------------------------- +# $obj->delete_file( $col_name, $recid, $save_scheme ); +#---------- +# deletes the files and records associated +# function that is usually used internally +# + my ( $self, $col_name, $recid, $save_scheme ) = @_; + +# get the path to the file + my $tbl = $self->_tbl(); + my $rec = $tbl->get({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_NOFILE', 'WARN', $col_name, $recid, $GT::SQL::error ); + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col_name, + $save_scheme, + ENCODE + ); + +# nuke the database record + $tbl->delete({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_FDELETE', 'WARN', $rec->{File_Name}, $GT::SQL::error); + +# nuke the file + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + $self->log( 'REMOVED', $rec->{File_Name} ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { +# -------------------------------------------------------------------------------------- +# $obj->delete_records( $condition ) +#---------- +# deletes all records addressed by the condition. +# usually used in conjunction with a delete of the parent table elements. +# BUT must be called before parent table is deleted +# + my ($self, $where) = @_; + my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error); + my @pk = $ptbl->pk() or return $self->error('FILE_PKREQ', 'WARN'); + @pk == 1 or return $self->error('FILE_PKSINGLE', 'WARN'); + my $pk = $pk[0]; + my %fcols = $ptbl->_file_cols(); + my $sth = $ptbl->select([$pk], $where); + my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error); + + while (my $raref = $sth->fetchrow_arrayref()) { + my $col_key = $raref->[0]; + my $fsth = $tbl->select([qw(ID ForeignColName File_Directory File_Name)], { ForeignColKey => "$col_key" }); + + while ( my $aref = $fsth->fetchrow_arrayref() ) { + my $fpath = $self->_file_full_path(map({$aref->[$_]} qw(3 2 0 1)), $fcols{$aref->[1]}->{file_save_scheme}, ENCODE) or next; + unlink $fpath or $self->error('FILE_NOUNLINK', 'WARN', $fpath, "$!"), next; + $self->log('REMOVED', $aref->[3]); + } + + $tbl->delete({ ForeignColKey => "$col_key" }) or $self->error('FILE_DBDELETE', 'WARN', $GT::SQL::error); + } +} +END_OF_SUB + +$COMPILE{update_records} = __LINE__ . <<'END_OF_SUB'; +sub update_records { +# -------------------------------------------------------------------------------------- +# $obj->update_records( $set, $condition ); +#---------- +# treated like $tbl->modify. will update all records with new files if required. +# if multiple records are to receive copies of the file, multiple copies of the files +# will be created on disk +# + my $self = shift; + my $set = shift or return $self->error ('BADARGS', 'FATAL', "First argument to update_records must be \$set of what was set."); + my $cond = shift or return $self->error ('BADARGS', 'FATAL', "Condition object must be passed as second argument."); + +# init variables + my $ptbl = $self->_parent_tbl(); + my @pk = $ptbl->pk() or return $self->error( 'FILE_PKREQ', 'WARN' ); + @pk == 1 or return $self->error( 'FILE_PKSINGLE', 'WARN' ); + my %fcols = $ptbl->_file_cols() or return $self->error ('BADARGS', 'FATAL', "update_records was called when there are no file columns, possibly corrupt def file."); + my %flocs = (); + +# find out which columns need to be updated + my @rcols = grep( defined ( $set->{$_} || $set->{$_."_del"} ), keys %fcols ) or return 1; # Nothing to do. + my $tbl = $self->_tbl(); + +# find out what records need to be updated + my $sth = $ptbl->select( [ $pk[0] ], $cond ); + while ( my $aref = $sth->fetchrow_arrayref() ) { + my $col_key = $aref->[0]; + +# now for each of the record's columns do what has to be done... delete, update, nothing? + foreach my $col ( @rcols ) { + + my $tmp = $flocs{$col} ||= {}; + my $fh = $tmp->{name} ? do { CORE::open SOURCE, "<$tmp->{path}"; \*SOURCE } : $self->get_fh( $col, $set ); + + ( not ref $fh and not $set->{$col."_del"} ) and ( $self->error( 'FILE_NOGLOBREF', 'WARN', $col ), next ); + + + my $fname = $tmp->{name} ||= ( $set->{$col."_filename"} || $self->get_filename( "$fh" ) ); + my $fdir = $tmp->{dir} ||= $fcols{$col}->{file_save_in}; + + my $rec; + if ( not $rec = $tbl->get({ ForeignColName => $col, ForeignColKey => "$col_key" }) ) { + $rec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + $rec->{ForeignColKey} = $col_key; + $rec->{ForeignColName} = $col; + $rec->{ID} = $tbl->add( $rec ) or $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ),next; + } + else { + + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + if ( ref $fh ) { + my $trec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + for ( keys %$trec ) { $rec->{$_} = $trec->{$_} }; + $tbl->modify($rec) or ( $self->error( 'FILE_DBUPDATE', 'WARN', $GT::SQL::error ),next ); + } + elsif ( $set->{$col."_del"} ) { + $tbl->delete({ ForeignColName => $col, ForeignColKey => "$col_key" }) or $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + next; + }; + + } + + my $fpath = $tmp->{path} ||= $self->_file_full_path( + ( $rec->{File_Name} = $tmp->{name} ), + $fdir, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + while (read($fh, my $buf, 512 * 1024)) { + print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ); + } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + close $fh; + + $self->log( 'ADDED', $rec->{File_Name}, $fdir ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_record} = __LINE__ . <<'END_OF_SUB'; +sub _delete_record { +# -------------------------------------------------------------------------------------- +# $obj->_delete_record( $columnname, $columnkey, $save_scheme ); +#---------- +# takes the parameters that identify a record in the _File uniquely and deletes +# record and file +# + my $self = shift; + my $col_name = shift or return; + my $col_key = shift or return; + my $save_scheme = shift or return;; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + +# get the column information + my $href = $tbl->get({ + ForeignColName => $col_name, + ForeignColKey => "$col_key", + }) or return $self->error( 'FILE_NOREC', 'WARN', $GT::SQL::error ); + + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols() or return; + +# get the filename of the record + my $fname = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $col_key, $col_name, $save_scheme, ENCODE); + +# delete the file now that we have the file path + unlink $fname or return $self->error( 'FILE_NOUNLINK', 'WARN', $fname, "$!" ); + +# nuke the record + $tbl->delete({ + ForeignColName => $col_name, + ForeignColKey => "$col_key", + }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# -------------------------------------------------------------------------------------- +# $obj->delete_call( $col_name ) +#---------- +# takes the name of a file column from the parent and deletes all files and records +# associated +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols(); + + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete_all() or return $self->error( 'FILE_DBDELETEALL', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { +# -------------------------------------------------------------------------------------- +# $obj->drop_col( $name ) +# ----- +# $name : name of column to drop +# ----- +# Will remove all files associated to that particular column. If there are no more +# file columns, as it is no longer required, drop the file table . +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return 1; + my $ptbl = $self->_parent_tbl(); + my %fcols = $ptbl->_file_cols(); + my $save_scheme = shift || $fcols{$name}->{file_save_scheme}; + my $sth = $tbl->select({ ForeignColName => $name }) or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $name, $save_scheme, ENCODE); + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete({ ForeignColName => $name }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + delete $fcols{$name}; + +# if there are no file based columns left, we can drop the file support table + require GT::SQL::Editor; + if ( not %fcols ) { + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table('remove') or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + } + + return 1; +} +END_OF_SUB + +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { +# -------------------------------------------------------------------------------------- +# $obj->drop_table(); +#---------- +# deletes all files in the table and drops the table (including records) +# + my $self = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $self->_parent_tbl()->_file_cols() or return; + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $save_scheme = $fcols{$href->{ForeignColName}}->{file_save_scheme}; + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $save_scheme, ENCODE); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + require GT::SQL::Editor; + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table() or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{open} = __LINE__ . <<'END_OF_SUB'; +sub open { +# -------------------------------------------------------------------------------------- +# $obj->open( $path_to_file ); +#---------- +# creates a GT::SQL::File::Fh Filehandle object +# + my $self = shift; + return GT::SQL::File::Fh->new(@_); +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# -------------------------------------------------------------------------------------- +# $obj->file_info( $columnname, $primarykeyvalue ); +#---------- +# returns a filehandle to file stored in database. if there is none, returns +# undef with an error set in $GT::SQL::error +# + my $self = shift; + my $name = shift or return; + my $key = shift or return; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptable->_file_cols(); + my $file_rec = $tbl->get({ ForeignColName => $name , ForeignColKey => $key }) or return $self->error( 'FILE_NOFILE', 'WARN', $name, $key, $GT::SQL::error ); + + my $relpath = $self->_file_full_path( + $file_rec->{File_Name}, + '', + $file_rec->{ID}, + $name, + $fcols{$name}->{file_save_scheme}, + ENCODE + ); + my $fpath = $file_rec->{File_Directory} . $relpath; + $file_rec->{File_RelativePath} = $relpath; + +# Files written to disk are escaped. They need to be escaped again for URLs. + require GT::CGI; + (my $relurl = $relpath) =~ s{([\\/])([^\\/]+)$}{$1 . GT::CGI->escape($2)}e; + $file_rec->{File_RelativeURL} = $relurl; + $file_rec->{File_URL} = $file_rec->{File_URL} . $relurl; + + return GT::SQL::File::Fh->new( $fpath, $file_rec ); +} +END_OF_SUB + +$COMPILE{_file_full_path} = __LINE__ . <<'END_OF_SUB'; +sub _file_full_path { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_full_path( $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) +#---------- +# $fname : filename +# $fdir : directory of file +# $fid : id of the parent record +# $save_scheme : hashed or simple +# $enc : if we should encode the filepath or try to decode it +#---------- +# returns the full path to the storeage location and name of the file the record +# points at +# the filename is typically encoded for the sake of special characters +# + my ( $self, $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) = @_; + + $save_scheme ||= 'HASHED'; + +# build paths to which we'll save all the information + $fdir = $self->_filepath_munge( $fdir, $fid, $save_scheme ); + $fname = $self->_filename_munge( $fname, $fid, $fcol, $save_scheme, $enc ); + my $fpath = "$fdir/$fname"; + + return $fpath; +} +END_OF_SUB + +$COMPILE{_file_getstats} = __LINE__ . <<'END_OF_SUB'; +sub _file_getstats { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_getstats( $fname, $fpath, $fsize ); +#---------- +# starts to build a record to be used for inserts/modifies into +# the _File database table +# + my ( $self, $fname, $fpath, $furl, $fsize ) = @_; + require GT::MIMETypes; + my $rec = { + File_Name => $fname || '', + File_Directory => $fpath || '', + File_MimeType => GT::MIMETypes->guess_type($fname), + File_Size => defined $fsize ? $fsize : '', + File_URL => $furl || '' + }; + + return $rec; +} +END_OF_SUB + +$COMPILE{_filename_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filename_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filename_munge( $fname, $fid, $fcol, $method, $enc ) +#---------- +# should only be called internally. changes the filename so it can be saved without +# name conflicts +# + my ( $self, $fname, $fid, $fcol, $method, $enc ) = @_; + + if ($enc) { + $fname =~ s/([^\w.,-])/sprintf("%%%02X",ord($1))/ge; + } + else { + $fname =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge; + } + +# Most filesystems have a maximum filename length of 255 characters + if (length $fname > 255) { +# Keep the filename extension + my ($ext) = $fname =~ /(\.\w+)$/; + $ext ||= ''; + require GT::MD5; + $fname = GT::MD5::md5_hex($fname) . $ext; + } + + return "$fid-$fname"; +} +END_OF_SUB + +$COMPILE{_filepath_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filepath_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filepath_munge(); +#---------- +# sets up the path directory where the file should be saved. +# + my ( $self, $fpath, $fid, $method ) = @_; + + if ( $method =~ /hashed/i ) { + my $fletter = ( reverse split //, $fid )[0]; + my $nfpath = "$fpath/$fletter"; + if ( $fpath ) { + -e $nfpath or mkdir $nfpath, 0777 or return warn "Couldn't make directory $nfpath because $!"; + } + $fpath = $nfpath; + } + + return $fpath; +} +END_OF_SUB + +$COMPILE{_check_file_chars} = __LINE__ . <<'END_OF_SUB'; +sub _check_file_chars { +#------------------------------------------------------------------------------- +# $obj->_check_file_chars( $fpath ); +#---------- +# return true if file path is ok +# + return $_[1] =~ /^[\w\/\\\-\.\:%]+$/; +} +END_OF_SUB + +$COMPILE{install} = __LINE__ . <<'END_OF_SUB'; +sub install { +#------------------------------------------------------------------------------- +# $obj->install( $options ); +#---------- +# creates the associate file parameter storage table +# $tops is passed into the creation option database +# + my ( $self, $opts ) = @_; + +# get the name of the table + my $ptbl_name = $opts->{parent_tablename} || $self->{parent_tablename}; + my $tb_name = $ptbl_name . '_Files'; + +# create the table + my $c = $self->creator( $tb_name ); + $c->cols({ + ID => { pos => 1, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + ForeignColName => { pos => 2, type => 'VARCHAR', size => 50 }, + ForeignColKey => { pos => 3, type => 'VARCHAR', size => 50 }, + File_Name => { pos => 4, type => 'VARCHAR', size => 255 }, + File_Directory => { pos => 5, type => 'VARCHAR', size => 255 }, + File_MimeType => { pos => 6, type => 'VARCHAR', size => 50 }, + File_Size => { pos => 7, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + File_URL => { pos => 8, type => 'VARCHAR', size => 255 }, + +# under consideration.... +# File_Width => { pos => 8, type => 'INT', unsigned => 1, regex => '^\d+$' }, +# File_Height => { pos => 9, type => 'INT', unsigned => 1, regex => '^\d+$' }, + + }); + $c->pk('ID'); + $c->ai('ID'); + $c->index({ fk_lookup => [ 'ForeignColName', 'ForeignColKey' ] }); + $c->create( $opts->{action} || 'force' ) or return; + + return 1; + +} +END_OF_SUB + +$COMPILE{_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _tbl { +#------------------------------------------------------------------------------- +# $obj->_tbl( $options ) +#---------- +# returns GT::SQL::Table for _File table +# + my ( $self, $opts ) = @_; + + $self->{table_object} and return $self->{table_object}; + + my $tbl = eval { + $self->new_table( $opts->{table} || ( + ( + $opts->{parent_tablename} + || $self->{parent_tablename} + || ( ref $self->{parent_table} ? + do { + my $prefix = $self->{connect}->{PREFIX}; + my $name = $self->{parent_table}->name(); + $name =~ s,^$prefix,,; + $name; + } + : + '' + ) ) . '_Files' + ) ); + }; + + return $self->{table_object} = $tbl; +} +END_OF_SUB + +$COMPILE{_parent_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _parent_tbl { +# ------------------------------------------------------------- +# $obj->_parent_tbl( $options ); +#---------- +# return the Table object for the parent table +# + my ( $self, $opts ) = @_; + $self->{parent_table} and return $self->{parent_table}; + return $self->_tbl( $self->{parent_table_name} || return ); +} +END_OF_SUB + +$COMPILE{File_Binary} = __LINE__ . <<'END_OF_SUB'; +sub File_Binary { +# ------------------------------------------------------------------- +# just returns true if the file is of binary type +# + my $self = shift; + defined $self->{File_Binary} and return $self->{File_Binary}; + $self->{file_fpath} and return $self->{File_Binary} = -B $self->{file_fpath}; + $self->{file_handle} and return $self->{File_Binary} = -B $self->{file_handle}; +} +END_OF_SUB + +$COMPILE{compare} = __LINE__ . <<'END_OF_SUB'; +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} +END_OF_SUB + +$COMPILE{get_filename} = __LINE__ . <<'END_OF_SUB'; +sub get_filename { +# ------------------------------------------------------------------- + my ($self, $fpath) = @_; + return +($fpath =~ /([^\\\/]+)$/)[0]; +} +END_OF_SUB + +$COMPILE{get_fh} = __LINE__ . <<'END_OF_SUB'; +sub get_fh { +# ------------------------------------------------------------------- + my ($self, $col, $values) = @_; + $values ||= {}; + + ref $values->{$col} and ref $values->{$col} ne 'SCALAR' and return $values->{$col}; + ref $values->{$col} eq 'SCALAR' and -f ${$values->{$col}} and -r _ and return GT::SQL::File->open(${$values->{$col}}); + return; +} +END_OF_SUB + +$COMPILE{pre_file_actions} = __LINE__ . <<'END_OF_SUB'; +sub pre_file_actions { +# ------------------------------------------------------------------- +# GT::SQL::File->pre_file_actions(); +#---------- +# Called before GT::SQL::Table::insert or GT::SQL::Table::update to setup all +# the columns and run tests to ensure the file is appropriate. Note that the +# $set hash will be modified (file columns are removed and/or modified and are +# returned). +# +# The $modify_ids (a single id or array ref of ids) argument is required for +# update()'s to verify that updates aren't made on rows that have file columns +# with not_null set and are currently empty. In addition to passing in to +# passing $modify_ids in, the GT::SQL::File object should also have the +# parent_table and connect options configured. For example, +# +# my $file = GT::SQL::File->new({ +# parent_table => $DB->table('Links'), +# connect => $DB->{connect} +# }); +# +# If $modify_ids is not passed in, then it is assumed the query will be an +# insert and all file columns with not_null set will be required. +# + my ($self, $fcols, $set, $opts, $modify_ids) = @_; + + $modify_ids = [$modify_ids] if ref $modify_ids ne 'ARRAY' and $modify_ids; + + my %fset; + for my $col (keys %$fcols) { +# insert() passes in through $opts, while modify passes them in through $set + my $delete = $opts->{"${col}_del"} || $set->{"${col}_del"}; + my $filename = $opts->{"${col}_filename"} || $set->{"${col}_filename"}; + my $fh = $set->{$col}; + +# Clean up the file columns (these will get set accordingly further down). +# This really doesn't have to be done since insert() and update() will only use +# valid columns, but we'll do it anyways. + delete $set->{"${col}_del"}; + delete $set->{"${col}_filename"}; + delete $set->{$col}; + +# A file has been uploaded, ignore requests to delete the file + if (ref $fh and -e $fh) { + $delete = undef; + } +# No or non-existent file passed in, make sure the file data isn't set + else { + $fh = undef; + $filename = undef; + } + +# Uploading a new file + if ($fh) { + my $max_size = $fcols->{$col}->{file_max_size} || 0; + return $self->warn('FILE_FILETOOBIG', $fh, -s $fh, $max_size) if $max_size and $max_size < -s $fh; + + $set->{$col} = $filename || $self->get_filename($fh); + $fset{$col} = $fh; + $fset{"${col}_filename"} = $filename if defined $filename and length $filename; + } +# Do our own not null checks here, so we can return a relevant error + elsif ($fcols->{$col}->{not_null}) { + +# You cannot delete a file from a not_null column during an update() - it must be replaced + if ($modify_ids and $delete) { + return $self->warn('FILE_NULLDELETE', $col); + } + elsif ($modify_ids) { +# The file column can be left blank on an update only if a file has already been uploaded + for (@$modify_ids) { + return $self->warn('FILE_NULLUPDATE', $col) unless $self->file_info($col, $_); + } + } +# This is an insert() - all not_null file columns should have a value set + else { + return $self->warn('FILE_NOTNULL', $col); + } + } + + if ($delete) { +# Deleting the file, so update the column in the parent table to '' + $set->{$col} = ''; + $fset{"${col}_del"} = $delete; + } + } + + return wantarray ? %fset : \%fset; +} +END_OF_SUB + +package GT::SQL::File::Fh; + +# =================================================================== +# Magic File Handle, lets you print the file name, but also act like +# a file handle for read, just like CGI.pm. +# +use strict qw/vars subs/; +no strict 'refs'; +use vars qw/$FH %FH_Conns $AUTOLOAD/; +use overload + '""' => \&as_string, + 'cmp' => \&compare, + 'fallback' => 1; +$FH = 1; +%FH_Conns = (); + +sub open { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + goto >::SQL::File::Fh::new; +} + +sub new { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + my ( $pkg, $file, $opt ) = @_; + $file or return; + + my $fid = $FH++; + my $fname = sprintf( "FH%05d", $fid ); + my $fh = \do { local *{$fname}; *{$fname} }; + + CORE::open ($fh, $file || '') or return; + + bless $fh, $pkg; + + my $obj = GT::SQL::File->new({ + %{$opt||{}}, + file_name => GT::SQL::File->get_filename( $file ), + file_fpath => $file, + }) or return; + + $obj->File_Binary() and binmode $fh; + + $FH_Conns{$$fh} = $obj; + + return $fh; +} + +sub as_string { +# ------------------------------------------------------------------- +# Return the filename, strip off leading junk first. +# + my $self = shift; + return $FH_Conns{$$self}->{file_fpath}; +} + +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} + + +sub AUTOLOAD { +# ------------------------------------------------------------------- + my $self = shift; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + + my $fh_ref = $FH_Conns{$$self} or return; + + if ( $fh_ref->can($what) ) { + return $fh_ref->$what(@_) + } + elsif ($GT::SQL::File::PERMIT_REFS->{$what}) { + $fh_ref->{$what} = shift if @_; + return $fh_ref->{$what}; + } + else { + return $fh_ref->error('FILE_UNKNOWNREF', 'FATAL', $what); + } +} + +sub DESTROY { +# ------------------------------------------------------------------- +# Close file handle. +# + my $self = shift; + delete $FH_Conns{$$self}; + close $self; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::File - adds file upload and download abilities to GT::SQL + +GT::SQL::File::Fh - basic file object + +=head1 DESCRIPTION + +GT::SQL::File is not created directly by the user. This module is an +internal module for GT::SQL to provide the abilty to upload/download +files into a database column (or so it seems). + +GT::SQL::File::Fh is often accessed by the user as well as created +by the user whenever the user wants to store a file in the database. + +=head2 Creating a new FILE Column + +When a new table is created or a column is converted into 'FILE' +type, two things are created. First a column of type text which will +save the name of the file that is being stored. Secondly, a +piggy-back table will be greated under the name +"parent_table_name_File". This new table will store the location of +the uploaded/stored file and various associated file attributes. + +To create a new file table, include a column something like the +following. + + File_Col_Name => { + + # common parameters + pos => 2, + type => 'FILE', + + # location of the directory where + # all the files should be saved + file_save_in => '/tmp', + + # the method all the files are saved + # 'hashed', or 'simple' + # + # Defaults to hashed, and stores files in: + # file_save_in/hashed_letter/ID + # Simple stores files in: + # file_save_in/ID_OwnName.OwnExt + file_save_scheme => 'hashed', + } ... + +=head2 Inserting into the Column + +Once you have the table created, to insert: + + # Include all the modules + use GT::SQL; + use GT::SQL::File; + + # First create a file object pointing to the file + $f = GT::SQL::File->open('/path/to/file.txt'); + + # Then create a table object + $DB = GT::SQL->new('path/to/defs'); + $tbl = $DB->table(); + + # Create the record + # the file field can also be GT::CGI::Fh type + $rec = { + File_Column => $f, + # ... and all the other columns + }; + +# optionally, if you know the path to the file, you can provide +# a scalar ref of the path and the module will autoload +# the values +# simple scalar values will be dropped + $rec = { + File_Column => \"/path/to/file.txt" + # ... and all the other columns + }; + + # Then to store the file + $id = $tbl->add( $rec ); + +=head2 Retreiving from Column + +When a file has been stored. A standard select will only return +the name of the file. + +To get a filehandle, taking the previous example, if we know the +unique id, you can do the following. + + $fh = $tbl->file_info( 'File_Column', $id ); + +You can use this file handle just like any other, however hidden +behind are special functions that can be used as follows: + + print "Content-type: ", $fh->File_MimeType(), "\n\n"; + print <$fh>; + +The following is a partial list of special functions you may access. + + + Method Returns + ------ ------- + File_Name the basic filename + File_Directory path to the file + File_MimeType mimetype of the file + File_Size site of the file + File_RelativePath the permuted file and directory without root + File_URL if possible, the URL to the requested file + File_RelativeURL the relative URL to the requested file + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Monitor.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Monitor.pm new file mode 100644 index 0000000..2ef9156 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Monitor.pm @@ -0,0 +1,149 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Monitor +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Monitor.pm,v 1.7 2008/12/05 01:28:49 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Monitor; +use strict; +use vars qw/@EXPORT_OK $CSS/; +use Carp qw/croak/; +use GT::CGI qw/:escape/; +require Exporter; +@EXPORT_OK = qw/query/; + +use constant CSS => <<'CSS'; + +CSS + + +sub query { +# ----------------------------------------------------------------------------- +# Handles the 'SQL Monitor' function of various Gossamer Threads products. +# Takes a hash of options: +# table - any GT::SQL table object +# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text' +# html - ('tab' or 'text' mode) whether values should be HTML escaped and the whole thing surrounded by a
         tag
        +#   query - the query to run
        +#   css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
        +# Returned is a hash reference containing:
        +#   db_prefix - the database prefix currently in use
        +#   style - the value of the 'style' option
        +#   query - the query performed
        +#   rows - the number of rows returned by the query, or possibly the number of rows affected
        +#   results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
        +#   error - set to 1 if an error occurred
        +#   error_connect - set to an error message if the database connection failed
        +#   error_prepare - set to an error message if the prepare failed
        +#   error_execute - set to an error message if the execute failed
        +#
        +    my %opts = @_;
        +
        +    $opts{table} and $opts{query} or croak "query() called without table and/or query options";
        +
        +    $opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
        +
        +    my %ret = (
        +        db_prefix => $opts{table}->{connect}->{PREFIX},
        +        style => $opts{style},
        +        query => $opts{query}
        +    );
        +
        +    my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
        +    my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
        +
        +    my $names = $sth->row_names;
        +
        +    $ret{rows} = $sth->rows || 0;
        +
        +    if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|EXPLAIN|sp_)/i) {
        +        my $table = '';
        +        my $data = $sth->fetchall_arrayref;
        +        if ($opts{style} and $opts{style} eq 'html') {
        +            $table .= defined $opts{css} ? $opts{css} : CSS;
        +            $table .= qq|\n|;
        +            $table .= "  \n";
        +            $table .= join '', map '    \n",
        +            @$names;
        +            $table .= "  \n";
        +            for (@$data) {
        +                $table .= "  \n";
        +                for (@$_) {
        +                    my $val = html_escape($_);
        +                    $val .= "
        " unless $val =~ /\S/; + $table .= qq| \n|; + } + $table .= " \n"; + } + $table .= "
        ' . html_escape($_) . "
        $val
        "; + } + elsif ($opts{style} and $opts{style} eq 'tabs') { + $table = $opts{html} ? '
        ' : '';
        +            for (@$data) {
        +                my @foo = map html_escape($_), @$_;
        +                $table .= join("\t", $opts{html} ? (map defined $_ ? html_escape($_) : '', @$_) : @$_) . "\n";
        +            }
        +            $table .= "
        " if $opts{html}; + } + else { # style = 'text' + my @max_width = (0) x @$names; + for ($names, @$data) { + for my $i (0 .. $#$_) { + my $width = length $_->[$i]; + $max_width[$i] = $width if $width > $max_width[$i]; + } + } + $table = join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + $table .= '|'; + for my $i (0 .. $#$names) { + $table .= sprintf " %-$max_width[$i]s |", $names->[$i]; + } + $table .= "\n"; + $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + for (@$data) { + $table .= '|'; + for my $i (0 .. $#$names) { + $table .= sprintf " %-$max_width[$i]s |", $_->[$i]; + } + $table .= "\n"; + } + $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + $table = "
        " . html_escape($table) . "
        " if $opts{html}; + } + $ret{results} = \$table; + } + else { + $ret{results} = "Rows affected: $ret{rows}"; + } + + return \%ret; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Relation.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Relation.pm new file mode 100644 index 0000000..635f8c5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Relation.pm @@ -0,0 +1,1897 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Relation +# Author : Jean-Michel Hiver +# $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Utility modules that makes it possible to treat joins between +# multiple tables almost as if it was a single table. +# + +package GT::SQL::Relation; +# ================================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERROR_MESSAGE/; + +$ERROR_MESSAGE = 'GT::SQL'; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.102 $ =~ /(\d+)\.(\d+)/; + +sub DESTROY {} + +sub new { +# ----------------------------------------------------------- +# new GT::SQL::Relation ( +# tables => { table name => object } +# debug => debug level, +# _err_pkg => package name, +# ); +# ------------------------------------------------- +# Constructs (or returns if it already exists) a +# new GT::SQL::Relation object with the parameters specified +# above. +# +# +# new GT::SQL::Relation ( $hashref ); +# ---------------------------------- +# Same thing, $hashref being a reference to a +# hash which would be similar to what's above. +# +# +# $obj->new(LIST); +# ----------------- +# Internal use only. Creates a new Relation object from $obj +# with list being a subset of the tables which are being +# contained in $obj. +# + my $class = shift; + + if (ref $class) { + # if the first argument is a reference, then we assume that we + # are constructing from a Relation object that handles all the + # data that has to be passed in. + my $this = $class; + my $class = ref $class; + + my @tables = map { (ref $_) ? $_->{name} : $_ } @_; + + my $opts = {}; + $opts->{_debug} = $this->{_debug} || $DEBUG; + $opts->{_err_pkg} = $this->{_err_pkg}; + $opts->{connect} = $this->{connect}; + $opts->{tables} = { map { $_ => $this->{tables}->{$_} } @tables }; + $opts->{tables_ord} = \@tables; + + return $class->new($opts); + } + else { + my $self = bless {}, $class; + my $opts = {}; + + if (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (@_ % 2 == 0) { $opts = { @_ } } + else { + $self->error("BADARGS", "FATAL", "new GT::SQL::Relation (HASH or HASHREF)"); + } + + # same thing for name - must be an array ref + ref $opts->{tables} eq 'HASH' or + return $self->error("BADARGS", "FATAL", "$class new(HASH_REF or HASH). name must be a ref to a list of table names."); + + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} if exists $opts->{_err_pkg}; + $self->{tables} = $opts->{tables}; + $self->{connect} = $opts->{connect}; + $self->{fk} = {}; + + # if an order was specified for the tables, use it, otherwise + # sort the tables in lexicographical order. + my @tables_ord = sort keys %{$self->{tables}}; + if ($opts->{tables_ord}) { @tables_ord = @{$opts->{tables_ord}} } + + $self->{tables_ord} = \@tables_ord; + + # this is a hash that has { $table names => $schema object } + $self->{last_where} = undef; + $self->{last_hits} = undef; + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; + } +} + +# ------------------------------------------------------------------------------------- # +# INSERT # +# ------------------------------------------------------------------------------------- # + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $obj->insert($col1 => $val1, +# ..., +# $coln => $valn, +# ); +# ----------------------------- +# Will fill +# the tables whenever it can according to the +# insert parameters. +# +# returns TRUE if insert succeeded, +# FALSE otherwise. +# +# $obj->insert($hashref); +# ------------------------------ +# Same as above. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_insert($split); + if (! $added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +$COMPILE{add} = __LINE__ . <<'END_OF_SUB'; +sub add { +# ----------------------------------------------------------- +# add() : Adds a record into the current relation object, and +# returns a hash of primary key => value. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_add($split); + if (!$added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# SELECT # +# ------------------------------------------------------------------------------------- # + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where +# condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that +# you wish returned. If none are specified all +# fields will be returned. +# + my $self = shift; + $self->connect or return; + +# Get a list of fields to select. + my (@fields, @cond, $left_join); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_}; } + elsif (not ref $_) { ($_ eq 'left_join') ? ($left_join = 1) : push @fields, $_; } + else { push @cond, $self->_build_cond($_); } + } + @fields = map { $self->_complete_name($_) } grep { defined and length } @fields; + @fields or (@fields = ('*')); + + my $fields = join ',' => @fields; + my $condition = @cond > 1 ? GT::SQL::Condition->new(@cond) : $cond[0]; + +# building the join condition for this query + my @relations = values %{$self->{tables}}; + my $join = $self->_join_query(\@relations); + +# building the select options, if any + my $sel_opts = ''; + if (defined $self->select_options) { $sel_opts = " " . join " ", $self->select_options } + $self->{sel_opts} = undef; + +# Any fk specifics + $self->{fk} ||= {}; + my $orig_fk = {}; + for my $table (keys %{$self->{fk}}) { + if (defined $self->{fk}->{$table}) { + $orig_fk->{$table} = $self->{fk}->{$table}; + $self->{tables}->{$table}->{schema}->{fk}->{$table} = $self->{fk}->{$table}; + } + } + + my $sql; + if ($left_join) { + my $tables = $self->{tables_ord}->[0] . ' LEFT OUTER JOIN ' . $self->{tables_ord}->[1] . ' ON ' . $join; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "WHERE ($string)" if $string; + } + + $sql = qq!SELECT $fields FROM $tables $cond_sql!; + $sql .= $sel_opts if $sel_opts; + } + else { + my $tables = join ',' => sort keys %{$self->{tables}}; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "($string)" if $string; + } + + my $where = ($cond_sql or $join) ? "WHERE " : ""; + $where .= "$join " if $join; + $where .= 'AND ' if $join and $cond_sql; + $where .= "$cond_sql" if $cond_sql; + $sql = qq!SELECT $fields FROM $tables $where!; + $sql .= $sel_opts if $sel_opts; + } + + my $sth = $self->{driver}->prepare($sql) or return; + $sth->execute or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it now +# without an additional query. + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined($3)) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif ($1) { + ($limit, $offset) = ($1, $2 || 0); + } + else { + ($offset, $limit) = ($4, $5); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + + $self->{sel_opts} = []; + +# Save the last query for future use. + $self->{last_where} = $condition ? $condition->clone : undef; + + for ( keys %$orig_fk ) { + $self->{tables}->{$_}->{schema}->{fk}->{$_} = $orig_fk->{$_}; + } + $self->{fk} = {}; + return $sth; +} + +$COMPILE{join_on} = __LINE__ . <<'END_OF_SUB'; +sub join_on { +# ------------------------------------------------------------------- +# Change how tables join + my ( $self, $tb, %change ) = @_; + my $p = $self->prefix; + $tb = $p . $tb; + return unless exists $self->{tables}{$tb}; + for my $table ( keys %change ) { + my $cp = $p . $table; + next unless exists $self->{tables}{$cp}; + $self->{tables}->{$tb}->{schema}->{fk}->{$cp} = $change{$table}; + } +} +END_OF_SUB + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + my %join; + foreach my $relation (@$relations) { + my $relation_name = $relation->{name}; + my @join_tables = keys %{$relation->{schema}->{fk}}; + foreach my $join_table (@join_tables) { + if ($self->{tables}->{$join_table}) { + my $fk = $relation->{schema}->{fk}->{$join_table}; + for my $key (keys %$fk) { + $join{"$relation_name.$key"} = "$join_table.$fk->{$key}" unless $relation_name eq $join_table; # Ignore foreign keys to the same table + } + } + } + } + return join " AND ", map "$_ = $join{$_}", keys %join; +} + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want +# prepended to your search. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_ > 0; + if (wantarray) { ($self->{sel_opts}) ? @{$self->{sel_opts}} : () } + else { ($self->{sel_opts}) ? $self->{sel_opts} : [] } +} + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ----------------------------------------------------------- +# $obj->query($HASH or $CGI); +# ---------------------------- +# Performs a query based on the options in the hash. +# $HASH can be a hash ref, hash or CGI object. +# +# Returns the result of a query as fetchall_arrayref. +# + my $self = shift; + my $sth = $self->_query(@_) or return; + return $sth->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ----------------------------------------------------------- +# $obj->query_sth($HASH or $CGI); +# -------------------------------- +# Same as query but returns the sth object. +# + shift->_query(@_) +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# DELETE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{delete} = __LINE__ . <<'END_OF_SUB'; +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition, $opt); +# -------------------------------- +# $condition is a condition on the current +# join relation, +# +# $opt is a string which can be either 'abort', +# 'ignore', or 'cascade'. +# + my $self = shift; + my $cond = shift; + my $opt = shift || 'cascade'; + + $cond = $self->_build_cond($cond); + + $self->{last_where} = $cond ? $cond->clone : undef; + + my $rows; + if ($opt eq 'ignore') { + my $split = $self->_split_fields($cond); + for (keys %{$split}) { + $rows += $self->{$_}->delete($split->{$_}, 'ignore') or return; + } + } + elsif ($opt eq 'abort') { + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, $cond) or return; + if (!$q->rows) { + $rows = "0E0" unless ($q->rows); + } + else { + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + foreach my $referencing ($self->_referencing_relations) { + unless ($self->_can_delete($h, $referencing)) { + return $self->error("DEPENDENCY", "WARN", $referencing); + } + } + } + $rows = $self->_delete_cascade($cond->new_clean); + } + } + elsif ($opt eq 'cascade') { + $rows = $self->_delete_cascade($cond) or return; + } + return ($rows == 0) ? '0E0' : $rows; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# deletes all the records in this relation +# + my $self = shift; + my $opt = shift || 'abort'; + foreach my $rel ($self->_referencing_relations) { ($rel->delete_all($opt)) ? next : return } + foreach my $rel ($self->_referenced_relations) { ($rel->delete_all($opt)) ? next : return } + return 1; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# UPDATE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# ----------------------------------------------------------- +# $obj->update($hashref, $hashref); +# $obj->update($hashref, $condition); +# ------------------------------------ +# $hashref are the fields to update +# +# $condition is a condition on the current +# join relation. +# +# A limitation exists: in a relation one to many, +# it is not possible to perform an update on the +# attributes that are in the "one" entity. +# + my ($self, $hash, $cond) = @_; + (ref $self and ref $hash and ref $cond) or $self->error("BADARGS", "FATAL", '$obj->update(HASH, GT::SQL::Condition or HASH)'); + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + $cond = $self->_build_cond($cond); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + my ($upd, $rec) = ($hash->{$rel->{name}}, $h); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec2 = {}; + my $prefix = $rel->{name} . "."; + foreach my $col (keys %{$rel_rec}) { + my $col2 = $col; + $col2 =~ s/^\Q$prefix\E//; + $rel_rec2->{$col2} = $rel_rec->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + + unless (defined $rel->update($upd, $rel_rec2)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + + my $in = $self->common_param(@_); + + # first of all complete $in attributes + my ($hash, $cond); + for my $col (keys %$in) { + if (my $completed = $self->_complete_name($col, 1)) { + $hash->{$completed} = $in->{$col}; + } + } + + # let's build the $condition + my $condition = { map { + $_ => $hash->{$_} + } $self->pk }; + + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + + $cond = $self->_build_cond($condition); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(\@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec = {}; + foreach my $col (keys %{$h}) { + next unless $col =~ /^\Q$rel->{name}\E\./; + my $col2 = $col; + $col2 =~ s/^[^.]+\.//; + $rel_rec->{$col2} = defined($hash->{$rel->{name}}->{$col2}) ? $hash->{$rel->{name}}->{$col2} : defined($hash->{$rel->{name}}->{$col}) ? $hash->{$rel->{name}}->{$col} : $h->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + unless (defined $rel->modify($rel_rec)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# COUNT/GET # +# ------------------------------------------------------------------------------------- # + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# $obj->get($condition, $opt); +# ----------------------------- +# $condition is the condition for the row that has to be +# retrieved. $opt can be 'ARRAY' or 'HASH'. The first row +# of the query is returned, which makes the get method +# mostly useful to retrieve rows from the primary key +# values. +# + my $self = shift; + my $cond = shift; + if (ref $cond eq 'ARRAY') { $cond = { @{$cond} } } + my $method = shift || 'HASH'; + $method = (uc $method eq 'ARRAY') ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond) or return; + return $sth->$method(); +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# ACCESSSORS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the relation columns as a hash which has +# the columns names as a key and their type as a +# value. +# + my $self = shift; + my @res; + if (@_) { $self->error('BADARGS', 'FATAL', '$obj->cols;') } + +# if the number of table objects that handles the current +# relation object equals zero, then returns an empty hash. + my @names = $self->name; + if (@names == 0) { return {} } + else { + my $res = {}; + my @referencing = $self->_referencing_relations; + my @referenced = $self->_referenced_relations; + if (@referenced) { + +# if in the current Relation object there exists some +# tables which are referenced by other tables within +# the current relation object, then + my %referenced_cols = $self->new(@referenced)->cols; + my @referenced_cols = keys %referenced_cols; + +# remove columns which are referenced by referencing +# tables because we don't wanna have these duplicates. + my @rem_cols; + foreach my $referencing (@referencing) { + foreach my $target (keys %{$referencing->{schema}->{fk}}) { + if (defined $self->{tables}->{$target}) { + push @rem_cols, map { $target .'.'. $_ } keys %{$referencing->{schema}->{fk}->{$target}}; + } + } + } + my @cols_left = _minus(\@referenced_cols, \@rem_cols); + map { $res->{$_} = $referenced_cols{$_} } @cols_left; + } + +# add then all low level columns, and return. + foreach my $referencing (@referencing) { + my %referencing_cols = %{$referencing->{schema}->{cols}}; + map { $res->{$referencing->{name} .'.'. $_} = $referencing_cols{$_} } keys %referencing_cols; + } + + return $res unless wantarray; + +# Wantarray has been set so create a copy of the res whose +# first and second level references can be clobbered. +# This assumes that the values side of the res will +# always been hashrefs + my %res_copy = %$res; + foreach my $res_name ( keys %res_copy ) { + + my %res_data = %{$res_copy{$res_name}}; + $res_copy{$res_name} = \%res_data; + + foreach ( keys %res_data ) { + if ( ref $res_data{$_} eq 'HASH' ) { + $res_data{$_} = {%{$res_data{$_}}}; + } + elsif ( ref $res_data{$_} eq 'ARRAY' ) { + $res_data{$_} = [@{$res_data{$_}}]; + } + } + } + + return %res_copy; + } +} +END_OF_SUB + +$COMPILE{col_names} = __LINE__ . <<'END_OF_SUB'; +sub col_names { +# ----------------------------------------------------------- +# Returns the columns names sorted the right order. +# + my $self = shift; + my %cols = $self->cols; + return sort { my $ret = $self->_col_cmp($a, $b); $ret } keys %cols; +} +END_OF_SUB + +# self explainatory +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { return shift->col_names(@_) } +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns a list of current relation names +# +# $obj->name(@names); +# -------------------- +# Returns a list of objects maching specified name. +# + my $self = shift; + if (@_) { + return map $self->{tables}->{$_}, @_ + } + else { + my @names = keys %{$self->{tables}}; + return wantarray ? @names : \@names; + } +} + +$COMPILE{unique} = __LINE__ . <<'END_OF_SUB'; +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns an array containing all the array refs +# for all the uniques. +# +# $obj->unique($field_name); +# --------------------------- +# Returns true if the field is unique. False otherwise. +# + my $self = shift; + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my %unq = %{$table->{schema}->{unique}}; + foreach my $unq (values %unq) { push @res, [ map { $table_name . "." . $_ } @{$unq} ] } + } + if (@_ == 1) { + my $s = shift; + return scalar grep { $s eq $_ } map { @{$_} } @res; + } + return wantarray ? @res : \@res; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns an array containing all the array refs +# for all the indexes. +# + my $self = shift; + if (@_ == 0) { + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my @idx = values %{$table->{schema}->{index}}; + foreach my $idx (@idx) { push @res, [ map { $table_name . "." . $_ } @{$idx} ] } + } + return wantarray ? @res : \@res; + } + else { return $self->error('BADARGS', 'FATAL', '$obj->index;') } +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# This method returns the columns reprensenting what +# would be the primary key of our JoinRelation if it +# ever existed. +# +# Tables which are referenced by other tables primary +# key shall not be exported, because they are the 'one' +# entities in a one-to-many relation. +# +# $obj->pk($field_name); +# ----------------------- +# Returns true if the field is in the primary +# key list. Returns false otherwise. +# + my $self = shift; + if (@_ == 0) { + my @result = (); + my @referencing = $self->_referenced_relations; + foreach my $referencing (@referencing) { push @result, map { $referencing->{name} .'.'. $_ } @{$referencing->{schema}->{pk}}; } + return sort { my $ret = $self->_col_cmp($a, $b); $ret; } @result; + } + elsif (@_ == 1) { + my $name = $self->_complete_name(shift); + return scalar grep { $name eq $_ } @{$self->{schema}->{pk}}; + } + else { $self->error('BADARGS', 'FATAL', '$obj->pk;') } +} +END_OF_SUB + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# returns a list of relation names which are referenced +# by the current relation. +# +# $obj->fk(RELATION_NAME); +# ------------------------- +# returns a hashref for relation RELATION_NAME which +# keys are the current relation "source" schema and which +# values are the "target" schema. +# + my $self = shift; + if (@_ > 1) { $self->error('BADARGS', 'FATAL', '$obj->fk; or $obj->fk($table_name)') } + if (@_ == 1) { + my $res = {}; + my $target = shift; + foreach my $rel (values %{$self->{tables}}) { + foreach my $rel_target (keys %{$rel->{schema}->{fk}}) { + if ($target eq $rel_target) { + my $h = $rel->{schema}->{fk}->{$rel_target}; + foreach my $k (keys %{$h}) { $res->{$rel->{name} .'.'. $k} = $h->{$k} } + } + } + } + return wantarray ? %{$res} : $res; + } + else { + my @res; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + push @res, $fk unless ($self->{tables}->{$fk}); + } + } + return wantarray ? @res : \@res; + } +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# $obj->fk_tables; +# ---------------- +# Returns a list of table that reference any +# of the table that's in the current joinrelation. +# +# $obj->fk_tables($table_name); +# ------------------------------ +# Returns true if $table_name is the name of a +# table that's referencing any of the tables that's +# in the current joinrelation. +# + my $self = shift; + my @result = $self->_minus( [ map { @{$_->{schema}->{fk_tables}} } values %{$self->{tables}} ], [ $self->name ] ); # very evil (c) + if (@_ == 1) { + my $check = shift; + return scalar grep { $check eq $_ } @result; + } + return wantarray ? @result : \@result; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + return wantarray ? [@{$self->unique}, @{$self->index}] : @{$self->unique}, @{$self->index}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# ai makes no sense in a Relation therefore I return nothing +# + my $self = shift; + my @res; + foreach my $rel (values %{$self->{tables}}) { + my $ai = $rel->{schema}->{ai} or next; + $ai = $rel->{name} . '.' . $ai; + push @res, $ai; + } + return unless @res; + return wantarray ? @res : \@res; + +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# INTERNAL METHODS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{_build_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_cond { +# ----------------------------------------------------------- +# this subroutine is made to build conditions which may not +# be a Condition object for selects and deletes. +# + my ($self, $condition) = @_; + my $prefix = $self->{connect}->{PREFIX}; + if (! defined $condition) { + return; + } + elsif (ref $condition eq 'HASH') { + my $tmp = new GT::SQL::Condition; + while (my ($col, $val) = each %$condition) { + $col = $self->_complete_name($col); + $tmp->add($col => '=' => $val); + } + return $tmp; + } + elsif (ref $condition eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$condition}); + return $tmp; + } + elsif (length $prefix and (ref $condition eq 'GT::SQL::Condition')) { + $self->_build_prefixed_cond($prefix, $condition); + return $condition; + } + else { + return $condition; + } +} +END_OF_SUB + +$COMPILE{_build_prefixed_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_prefixed_cond { +# ----------------------------------------------------------- +# $obj->_build_prefixed_cond($prefix, $cond) +# --------------------------------- +# + my ($self, $prefix, $condition) = @_; + foreach (@{$condition->{cond}}) { + if (ref $_ eq 'ARRAY') { + if ($_->[0] =~ /^[\w\.]+$/) { + $_->[0] = $self->_complete_name($_->[0]); + } + } + elsif (ref $_ eq 'GT::SQL::Condition') { + $self->_build_prefixed_cond($prefix, $_); + } + } + return $condition; +} +END_OF_SUB + +$COMPILE{_complete_name} = __LINE__ . <<'END_OF_SUB'; +sub _complete_name { +# ----------------------------------------------------------- +# Returns a Table.Attribute name of a column given Attribute, if possible. +# Takes an optional second argument - if passed and true, seeing 'abc.xyz' will +# return undef if 'abc' isn't a valid table. Without the true second argument, +# such a situation causes a fatal error. +# + my $self = shift; + my $col = shift or return $self->error('BADARGS', 'FATAL', "No column name specified."); + my $ignore_unknown = shift; + +# if column name is a scalar reference, just throw in the raw colname + ref $col eq 'SCALAR' and return $$col; + +# try to handle fully qualified column names + my ($relname, $colname) = split /\./, $col; + if ($relname and $colname) { + if (exists $self->{tables}->{$relname}) { + return $col; + } + else { + my $prefix = $self->{connect}->{PREFIX}; + if (exists $self->{tables}->{$prefix.$relname}) { + return $prefix.$relname.".".$colname; + } + elsif ($ignore_unknown) { + return undef; + } + else { + return $self->error('BADCOLS', 'FATAL', $col); + } + } + } + +# Otherwise, no . in column name. + my $found = 0; + my $return = $col; + foreach my $rel (values %{$self->{tables}}) { + my %h = %{$rel->{schema}->{cols}}; + if (exists $h{$col}) { + $found++; + $return = $rel->{name} . '.' . $col; + } + } + if ($found > 1) { + return $self->error('BADCOLS', 'FATAL', $col); + } + return $return; +} +END_OF_SUB + +$COMPILE{_col_cmp} = __LINE__ . <<'END_OF_SUB'; +sub _col_cmp { +# ----------------------------------------------------------- +# $a is something like TABLE.COL +# this method is used to sort the columns in the right order. +# + my ($self, $a, $b) = @_; + + $a and !$b and return -1; + $b and !$a and return 1; + !$a and !$b and return 0; + + my $one = $self->_complete_name($a); + my $two = $self->_complete_name($b); + my ($one_tab, $one_col) = split /\./, $one; + my ($two_tab, $two_col) = split /\./, $two; + + if ($one_tab eq $two_tab) { + return 0 if (!$one_tab or !$two_tab); + return ($self->{tables}->{$one_tab}->{schema}->{cols}->{$one_col}->{pos} <=> $self->{tables}->{$one_tab}->{schema}->{cols}->{$two_col}->{pos}); + } + else { + my @tables_ord = @{$self->{tables_ord}}; + while (my $table = shift(@tables_ord)) { + if ($table eq $one_tab) { return -1 } + if ($table eq $two_tab) { return 1 } + } + return 0; + } +} +END_OF_SUB + +$COMPILE{_insert} = __LINE__ . <<'END_OF_SUB'; +sub _insert { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $sth = $rel->insert($split->{$rel->{name}}) or return; + unless ($sth) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $sth = $rel->insert(%{$split->{$name}}); + unless ($sth) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $column_hash (values %added) { + foreach my $col (keys %{$column_hash}) { + $ids{$col} = $column_hash->{$col}; + } + } + return \%ids; +} +END_OF_SUB + +$COMPILE{_add} = __LINE__ . <<'END_OF_SUB'; +sub _add { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $id = $rel->add($split->{$rel->{name}}) or return; + unless ($id) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $id = $rel->add($split->{$name}); + unless ($id) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $table_name ( keys %added ) { + foreach my $col (keys %{$added{$table_name}}) { + $ids{"$table_name.".$col} = $added{$table_name}->{$col}; + } + } + + return \%ids; +} +END_OF_SUB + +$COMPILE{_minus} = __LINE__ . <<'END_OF_SUB'; +sub _minus { +# ----------------------------------------------------------- +# _minus($ary1, $ary2); +# ---------------------- +# $ary1 and $ary2 being two array refs, +# returns a list of all elements in $ary1 +# which are not in $ary2. +# + my ($self, $ary1, $ary2); + if (@_ == 0 || @_ == 1) { return } + elsif (@_ == 2) { ($ary1, $ary2) = @_ } + else { ($self, $ary1, $ary2) = @_ } + my @a1 = @{$ary1}; + my @a2 = @{$ary2}; + my @result; + foreach my $elt1 (@a1) { + my $push = 1; + foreach my $elt2 (@a2) { + $push = 0 if ($elt1 eq $elt2); + } + push @result, $elt1 if ($push == 1); + } + return @result; +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ----------------------------------------------------------- +# $self->_query; +# -------------- +# This function takes in special query arguments and turns them +# into a $opts array before doing the actual select on the +# database. +# + my $self = shift; + scalar $self->name() or return $self->error("NOTABLE", "FATAL"); + my $opts = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->_query( HASH or HASH_REF or CGI ) only.'); + + +# Strip out values that are empty or blank (as query is generally +# derived from cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} =~ /\S/ } keys %$opts; + $opts = \%input; + +# Prefix column names. + foreach my $field (keys %$opts) { + if ($field =~ /^(.*)-(gt|lt|le|ge|opt)$/) { + my $opt = $2; + if (my $full = $self->_complete_name("$1", 1)) { + $opts->{"$full-$opt"} = $opts->{$field}; + } + } + else { + if (my $full = $self->_complete_name($field, 1)) { + $opts->{$full} = $opts->{$field}; + } + } + } + +# Set search options and get query condition. + my $in = $self->_get_search_opts($opts); + my $cond = $self->build_query_cond($opts, scalar $self->cols); + + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless ($in->{mh} == -1); + my @sel = (); + if ($cond) { push @sel, $cond } + if ($in->{rs} and $cond) { push @sel, $in->{rs} } + if ($opts->{left_join} and $cond) { push @sel,'left_join' } + my $sth = $self->select(@sel) or return; + return $sth; +} +END_OF_SUB + +$COMPILE{_split_schema} = __LINE__ . <<'END_OF_SUB'; +sub _split_schema { +# ----------------------------------------------------------- +# $obj->_split_schema($hashref); +# ------------------------------- +# Turns { Table1.Attribute1 => value1, +# Table1.Attribute2 => value2, +# Table2.Attribute1 => value3 } +# +# into { Table1 => { Attribute1 => value1, +# Attribute2 => value2 } +# Table2 => { Attribute1 => value1 } } +# +# $obj->_split_schema($col1 => $val1, +# ..., +# $coln => $valn); +# +# it also looks if a field is referencing +# another, and if so duplicates the field +# key and value in the target table provided +# that this target table is in the current +# relation object. +# + my $self = shift; + my $arg; + if (ref $_[0] eq 'HASH') { $arg = shift } + elsif (not @_ % 2 and defined $_[0]) { $arg = {@_} } + else { return $self->error('BADARGS', 'FATAL', '$self->_split_schema(%hash)') } + my $result = {}; + +# first of all, some of the fields may not be specifying +# the table they belong to. + foreach my $col (keys %{$arg}) { + if (my $relname = $self->_complete_name($col, 1)) { + $arg->{$relname} = delete $arg->{$col}; + } + } + +# then, we separate fields in function of +# the table name that they have. + foreach my $complete_field (keys %{$arg}) { + next if (CORE::index($complete_field, '.') == -1); + my ($tablename, $fieldname) = split /\./, $complete_field; + $result->{$tablename} = {} unless (defined $result->{$tablename}); + $result->{$tablename}->{$fieldname} = $arg->{$complete_field}; + } + +# then, for each relation in our join object, complete +# names in $result + foreach my $relation (values %{$self->{tables}}) { + my $relation_name = $relation->{name}; + + # for all $relation foreign keys which are in $self + my %target_relation_names = %{$relation->{schema}->{fk}}; + + foreach my $target_relation_name (keys %target_relation_names) { + + # if the target relation exists in our join relation + # object and in our $hash + if (defined $self->{tables}->{$target_relation_name} and defined $result->{$target_relation_name}) { + + # then in $hash we set the values of the fields + # for the target relation depending on the values + # of the source relation. + my $fk = $relation->{schema}->{fk}->{$target_relation_name}; + foreach my $key (keys %{$fk}) { + my $value = $fk->{$key}; + $result->{$target_relation_name} = {} unless defined $result->{$target_relation_name}; + + my $fk_key = $relation->{schema}->{fk}->{$target_relation_name}->{$key}; + $result->{$relation_name}->{$key} = $result->{$target_relation_name}->{$fk_key} + if defined $result->{$target_relation_name}->{$fk_key}; + } + } + } + } + return $result; +} +END_OF_SUB + +$COMPILE{_referenced_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referenced_relations { +# ----------------------------------------------------------- +# $obj->_top_level_relations; +# --------------------------- +# This method returns the relations in the current +# which are referenced by other tables in the current join +# relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + my @referenced = _minus([ values %{$self->{tables}} ], [ map {$self->{tables}->{$_}} keys %names ]); + return @referenced; +} +END_OF_SUB + +$COMPILE{_referencing_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referencing_relations { +# ----------------------------------------------------------- +# $obj->_referencing_relations; +# ----------------------------- +# This method returns the tables in the current +# relation which are not referenced by any other +# tables in this relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + return map {$self->{tables}->{$_}} keys %names; +} +END_OF_SUB + +$COMPILE{_delete_cascade} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cascade { +# ----------------------------------------------------------- +# $obj->_delete_cascade($cond); +# ------------------------------ +# This method is used internaly to delete all the rows +# that match $cond for that joinrelation object. +# + my $self = shift; + my $count = 0; + + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, @_) or return; + while (my $array = $q->fetchrow_arrayref) { + $count++; + +# for each row that matches the condition + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + +# delete each low-level table rows (i.e. referencing tables) + foreach my $referencing ($self->_referencing_relations) { + $self->_delete_row($h, $referencing); + } + +# then delete each top-level table rows, if possible +# this may be broken when using tables with hierarchy +# level > 2. + foreach my $referenced ($self->_referenced_relations) { + if ($self->_can_delete($h, $referenced)) { $self->_delete_row($h, $referenced) } + } + } + return $count == 0 ? "0E0" : $count; +} +END_OF_SUB + +$COMPILE{_can_delete} = __LINE__ . <<'END_OF_SUB'; +sub _can_delete { +# ----------------------------------------------------------- +# $obj->_can_delete($record, $relation); +# --------------------------------------- +# Returns true if the record can be deleted +# from this relation without breaking dependancies +# or false otherwise. +# + my ($self, $rec, $rel) = (@_); + ref $rel or $rel = $self->{tables}->{$rel}; + + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# for all the schemas that exist in the database + foreach my $schema (keys %GT::SQL::Table::DATABASE) { + $self->debug("CREATING A NEW TABLE OBJECT") if ($self->{_debug} > 2); + + my $relation = $self->new_table($schema); + foreach my $relation_targetname ($relation->{schema}->{fk}) { + if ($relation_targetname eq $rel->{name}) { + my $schem = $relation->{schema}->{fk}->{$relation_targetname}; + +# I must make a copy of this because it's a reference from Schema +# and can potentially be used later, therefore it should not be +# modified. + my $schema = { map { $_ => $schem->{$_} } keys %{$schem} }; + foreach my $key (keys %{$schema}) { $schema->{$key} = $rel_rec->{$schema->{$key}} } + $relation->count($schema) and return 0; + } + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_row} = __LINE__ . <<'END_OF_SUB'; +sub _delete_row { +# ----------------------------------------------------------- +# $obj->_delete_row($record, $relation); +# --------------------------------------- +# + my ($self, $rec, $rel) = (@_); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + foreach my $col (keys %{$rel_rec}) { delete $rel_rec->{$col} unless (defined $rel_rec->{$col}) } + $rel->delete($rel_rec, 'cascade'); +} +END_OF_SUB + +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { +#------------------------------------------------------------------------------- + my $self = shift; + $_[0] and $self->{_file_cols} = undef; + $self->{_file_cols} and return %{$self->{_file_cols}}; + my %rec = (); + for my $table_name ( keys %{$self->{tables} } ) { + my %trec = $self->{tables}->{$table_name}->_file_cols() or next; + $rec{$table_name} = \%trec; + } + return %rec; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Relation - manage multiple table joins + +=head1 SYNOPSIS + + my $relation = $DB->table('Company', 'Employees'); + my $sth = $relation->select( { + Company.Name => 'Gossamer Threads', + Employees.Name => 'Alex Krohn' + }, ['Employees.Salary', 'Company.City'] ); + my ($salary, $city) = $sth->fetchrow_array; + print "Alex works in $city and earns $salary!\n"; + +=head1 DESCRIPTION + +This module aims at emulating a set of tables that are related to each other +via the use of foreign keys just as if it was one big table. + +The module interface should be as compatible as possible with GT::SQL::Table, +thus you should be familiar with GT::SQL::Table before even reading this. + +This documentation explains the differences between GT::SQL::Relation and +GT::SQL::Table and how the module internally works as well. + +=head2 How it works + +GT::SQL supports the concept of foreign keys (also known as external +references). Basically, two tables that are linked together using external +references can look like that: + + .-------------. .---------. + | EMPLOYEE | | COMPANY | + `-------------' `---------' + | ID | .--->ID | + | COMPANY_ID ----' | NAME | + | NAME | `---------' + | SALARY | + `-------------' + +In this example, the COMPANY_ID attribute relates the fact that a an EMPLOYEE +belongs to such or such COMPANY. + +Utilizing a Relation object can make these tables look like that: + + .----------------------. + | EMPLOYEE-COMPANY | + `----------------------' + | EMPLOYEE.ID | + | EMPLOYEE.COMPANY_ID | + | EMPLOYEE.NAME | + | EMPLOYEE.SALARY | + | COMPANY.NAME | + `----------------------' + +The first thing that can be seen from there is that COMPANY.ID has disappeared +from this "Virtual" table. + +Indeed, as for a given "joined" record this value must be the same in both +tables, representing the values twice would have been a useless source of +confusion. + +=head2 SELECT statements + +Selecting from a Relation object is pretty simple using the GT::SQL module. As +the interface is (almost) the same as L, the GT::SQL wrapper +returns Table or Relation objects depending on the arguments that are passed to +table. + + # This gives me a GT::SQL::Table object for + # the EMPLOYEE table. + my $emp = $sql->table('EMPLOYEE'); + + # This gives me a GT::SQL::Relation object for + # the relation EMPLOYEE-COMPANY tables + my $emp_cmp = $sql->table('EMPLOYEE','COMPANY'); + +From there, performing a select is pretty simple: + + # select all the people from a real cool company + my $sth = $emp_cmp->select( { COMPANY.NAME => "Gossamer Threads" } ) + +Internally, the generated SQL query would look like: + + SELECT EMPLOYEE.ID, EMPLOYEE.COMPANY_ID, EMPLOYEE.NAME + EMPLOYEE.SALARY, COMPANY.NAME + FROM EMPLOYEE, COMPANY + WHERE COMPANY.NAME = 'Gossamer Threads' AND + EMPLOYEE.COMPANY_ID = COMPANY.ID + +Note that the join condition is computed and automatically appended at the end +of the query, so you do not have to worry about this. + +=head2 SELECT options + +The select options for relation are similar to that of table, you have +select_options() which will be set for the next query done. Example: + + $relation->select_options("LIMIT 10"); + +This would append 'LIMIT 10' to your next select query. Another useful thing +is join_on(). join_on() allows you to specify the FK relation for the nextr +select. This overrides what is in the def files. It is useful for allowing you +to have one table which will be join differently depending on what you are +doing. The argument to this are the same as to fk(). +Example: + + $relation->join_on( remote_table => { local_column => remote_column } ); + +The FK relation will be changed to this the next time you call select() but +then it will be cleared. + +=head2 Listing the relation columns + +* As previously said, the cols() method when invoked on a GT::SQL::Relation +object does not return all the columns, removing the duplicate external +references. So, how does it decides which column to keep and which one to +return? + +In the EMPLOYEE-COMPANY example we have the constraint +EMPLOYEE.COMPANY_ID => COMPANY.ID and it keeps COMPANY_ID, i.e. the foreign key +instead of the key itself. + +=head2 Relation primary key + +* The pk() method has to return the table primary key. The property of a primary +key is that it is a non-null unique record identifier. When pk() is invoked on +a Relation object, this base definition is applied to construct the object +primary key. + +To find a unique set of fields that makes a good primary key for a Relation +object, the following, simple algorithm is used: + + . . + . for each table . + . if the table is not referenced by another table that . + . is in the current relation . + . do . + . append the current table's primary key fields to . + . the Relation primary key fields . + . end-do . + . end-if . + . end-for . + . . + +This algorithm selects all the tables that represent the "many" in one-to-many +relations, and for all these tables add a list of fields which ensure a record +uniqueness. + +=head2 Foreign keys management + +* When invoked on a GT::SQL::Table object, the fk() method returns a hash which +has the following general structure: + + { + target_table_1 => { + source_col_1 => target_col_1, + source_col_2 => target_col_2 + }, + target_table_2 => { + source_col_1 => target_col_1 + } + } + +The GT::SQL::Relation module returns a hash which has the same structure. The +only difference is that it does not returns the external references which are +managed internally. + +This is done for two reasons: As one field is removed from a Relation table, it +would not have been very logical to return a structure that point to +non-existent fields. + +Moreover, these internal references from the "Relation" point of view have +nothing to do with the external world and thus should not be shown. + +(i.e. EMPLOYEE.COMPANY_ID |===> COMPANY.ID would not count in our example) + +=head2 Inserting data + +The interface for inserting data in a Relation is the same as the one that is +being used for Table. However, because rows are being inserted in a relation +one-to-many, things internally work a bit differently. + +The Relation insert() method takes an optional argument, which can be +'complete' or 'abort' (default being complete). + +insert() splits the relation columns into separate records that can be inserted +in a single table. However, some of the records may exist already! + +for example, if we perform: + + $sql = shift; # our GT::SQL object + $rel = $sql->table(qw/EMPLOYEE COMPANY/); + $rel->insert({ + 'EMPLOYEE.NAME' => $your_name, + 'EMPLOYEE.SALARY' => $big_buck, + 'COMPANY.NAME' => "Gossamer Threads" + }); + +Obviously the company "Gossamer Threads" already exists, but you were not in +the "EMPLOYEE" table. Thus, when 'complete' is specified (it is the default +option), the program will not complain if a record to insert already exists but +just warns and continue the insertion work. + +In other words, Gossamer Threads exists already and it will not be inserted +twice, but the employee will still be inserted and will belong to this company. + +On the other hand, if you specify "abort", then no data is inserted if a +record that has to be inserted would trigger an error in GT::SQL::Table. + +This feature can be useful if you want to insert a relation record assuming +that none of the entities that you specify should exist. + +=head2 Deleting data + +Deleting data from a Relation object works using the following pattern: + + . . + . for each row that matches the delete condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . delete the record . + . end-do . + . . + . for each table that is being referenced by another . + . table in the current relation object . + . do . + . delete the record unless there exists . + . some "referencing" data. . + . end-do . + . . + +As I feel that this explanation is probably very confusing, let us see how it +works using our classical example (The salary column has been removed). + + .-------------------------------------------------------------. + | EMPLOYEE.ID | COMPANY_ID | EMPLOYEE.NAME | COMPANY.NAME | + `-------------------------------------------------------------' + | 1 | 1 | Alex | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 2 | 1 | Scott | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 3 | 1 | Aki | Gossamer Threads | + `-------------------------------------------------------------' + +Now let us say that we do the following: + + # remove all the crazy geeks + $relation->delete({ 'EMPLOYEE.NAME' => 'Scott' }); + +This will remove "Scott" from the EMPLOYEE table, but of course +Gossamer Threads will not be deleted because there still exists Alex and Aki +that would reference it. + +Now if we do: + + $relation->delete({ 'COMPANY.NAME' => 'Gossamer Threads' }); + +or even + + my $condition = new GT::SQL::Condition; + $condition->add(qw/EMPLOYEE.NAME LIKE %/); + $relation->delete($condition); + +Then we have generated a condition that matches all the employees, this means +that when the last record will be deleted, then the company Gossamer Threads +will have no more employees and therefore will be deleted. + +(Yeah, well, this is for the purpose of this example, of course this will never +happen in real life :) ) + +=head2 Updating records + +Currently, there exists a limitation on updating records in a Relation, which +is that only the records that represent the "many" part of the Relation are +updated. + +The way it proceeds to perform the update is pretty simple: + + . . + . for each row that matches the update condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . update the record . + . end-do . + . . + +That means that this will work: + + # SALARY being a property of EMPLOYEE, it will be updated + # because EMPLOYEE references COMPANY and therefore is a + # "many" + $relation->update({ SALARY => $big_bill }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + + # nope, you cannot use Relation to update the COMPANY table that + # way, this will not do anything. + $relation->update({ 'COMPANY.NAME' => 'New_Name' }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + +Who would like to change such a great name anyway ? + +=head2 Selecting Records + +Select behaves exactly like L select. The only difference is +the ability to specify LEFT JOINs. For instance, if you want to see a list of +Employees who don't belong to a company, you can do: + + my $relation = $DB->table('Employees', 'Company'); + my $cond = GT::SQL::Condition->new('Company.ID', 'IS', \'NULL'); + my $sth = $relation->select('left_join', $cond); + +The order of tables specified in the relation constructor is important! + +In selecting columns, calling functions utilizing fully qualified column names +will cause GT::SQL::Relation to fail. Simply turn the values into references +like below. + + my $sth = $relation->select("MIN(Company.ID)"); # will fail + + my $sth = $relation->select(\"MIN(Company.ID)"); # will work + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search.pm new file mode 100644 index 0000000..f2e0d86 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search.pm @@ -0,0 +1,585 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# highlevel class for searching, works with GT::SQL::Indexer +# + +package GT::SQL::Search; +#-------------------------------------------------------------------------------- + +# pragmas +use strict; +use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/; + +# includes +use GT::Base; +use GT::AutoLoader; + +# variables +$VERSION = sprintf "%d.%03d", q$Revision: 1.62 $ =~ /(\d+)\.(\d+)/; +@ISA = qw(GT::Base); +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + UNKNOWNDRIVER => 'Unknown driver requested: %s', + NOTABLE => 'Cannot find reference to table object' +}; + +sub load_search { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Search'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Search"; + return $pkg->load(@_); +} + +sub load_indexer { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Indexer'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Indexer"; + + return $pkg->load(@_); +} + +sub driver_ok { +#-------------------------------------------------------------------------------- +# checks to see if a particular driver is allowed on this system +# + my $class = shift; + my $driver = uc shift or return; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $mode = $opts->{mode} || 'Indexer'; + my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' ); + my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode; + + eval { require "GT/SQL/Search/$driver/$mode.pm" }; + $@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver); + return $pkg->can('ok') ? $pkg->ok($tbl) : 1; +} + +sub load_driver { +#-------------------------------------------------------------------------------- +# Loads a driver into memory. +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $tbl = $opts->{table}; + my $mode = $opts->{mode} || 'Indexer'; + my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED'); + + require "GT/SQL/Search/$driver/$mode.pm"; + return $driver; +} + +sub available_drivers { +#-------------------------------------------------------------------------------- +# Returns a list of available drivers. +# + my $class = shift; + + (my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//; + opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!"); + my @arr; + for my $driver_name (readdir DHANDLE) { + next if $driver_name =~ y/a-z//; + next if $driver_name eq 'LUCENE'; + -f "$path/$driver_name/Search.pm" and -r _ or next; + -f "$path/$driver_name/Indexer.pm" and -r _ or next; + my $loaded = eval { + require "GT/SQL/Search/$driver_name/Search.pm"; + require "GT/SQL/Search/$driver_name/Indexer.pm"; + }; + push @arr, $driver_name if $loaded; + } + closedir DHANDLE; + return wantarray ? @arr : \@arr; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Search - internal driver for searching + +=head1 SYNOPSIS + +This implements the query string based searching scheme for GT::SQL. Driver +based, it is designed to take advantage of the different indexing schemes +available on different database engines. + +=head1 DESCRIPTION + +Instead of describing how Search.pm is interfaced* this will describe how a +driver should be structured and how a new driver can be implemented. + +* as it is never accessed directly by the programmer as it was designed to be +called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth + +=head2 Drivers + +A driver has two parts. The Indexer and the Search packages are the most +important. Howserver, for any driver in the search, there must exist a directory +with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES +for Postgres. Within each driver directory, The Indexer and Search portions of +the driver contains all the information required for initializing the database +table and searching the database. + +The Indexing package of the driver handles all the data that is manipulated in +the database and also the initializes and the database for indexing. + +The Search package handles the queries and retrieves results for the eventual +consumption by the calling program. + +Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base +and operate by overriding certain key functions. + +The next few sections will cover how to create a search driver, and assumes a +fair bit of familiarity with GT::SQL. + +=head2 Structure of an Indexing Driver + +The following is an absolutely simple skeleton driver that does nothing and but +called "CUSTOM". Found in the CUSTOM directory, this is the search package, and +would be call Search.pm in the GT/SQL/Search/CUSTOM library directory. + + package GT::SQL::Search::CUSTOM::Search; + #------------------------------------------ + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) }; + + # overrides would go here + + 1; + +For the indexer, another file, Indexer.pm would be found in the +GT/SQL/Search/CUSTOM directory. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + + # overrides would go here + + 1; + +The almost empty subs that immediately return with a value are functions that +can be overridden to do special tasks. More will be detailed later. + +The Driver has been split into two packages. The original package name, +GT::SQL::Search::Nothing, houses the Search package. +GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system. +"::Indexer" must be appended to the orginial search name for the indexer. + +Each of the override functions are triggered at points just before and after a +major event occurs in GT::SQL. Depending on the type of actions you require, you +pick and chose which events you'd like your driver to attach to. + +=head2 Structure of Indexing Driver + +The Indexer is responsible for creating all the indexes, maintaining them and +when the table is dropped, removing all the associated indexes. + +The following header must be defined for the Indexer. +GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::Base; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +In addition to the header, the following function must be defined. +GT::SQL::Search::Driver::Indexer::load creates the new object and allows for +special preinitialization that must occur. You can also create another driver +silently (such as defaulting to INTERNAL after a version check fails). + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + +Finally, there are the overrides. None of the override functions need be defined +in your driver. Any calls made to undefined methods will silently fallback to +the superclass driver's methods. When a method has been overridden, the function +must return a true value when it is successful, otherwise the action will fail +and an error generated. + +Whenever a object is created it will receive one property $self->{table} which +is the table that is being worked upon. This property is available in all the +method calls and is required for methods such as _create_table and +_drop_search_driver methods. + +When a table is first created or when a table is destroyed the following two +functions are called. They are not passed any special values, however, these are +all class methods and $self->{table} will be a reference to the current table in +use. + +This set of overrides are used by GT::SQL::Creator when the ::create method is +called. They are called just prior and then after the create table sql query has +been executed. + +=over 2 + +=item pre_create_table + +=item post_create_table + +These functions receive no special parameters. They will receive the data to the +table in the $self->{table} property. + +=back + +This next set of functions take place in GT::SQL::Editor. + +=over 2 + +=item drop_search_driver + +This method receives no special parameters but is responsible for removing all +indexes and "things" associated with the indexing schema. + +=item add_search_driver + +Receives no extra parameters. Creates all indexes and does all actions required +to initialize indexing scheme. + +=item pre_add_column + +=item post_add_column + +The previous two functions are called just before and after a new column is +added. + +pre_add_column accepts $name (of column), $col (hashref of column attributes). +The method will only be called if the column has a weight associated with it. +The function must return a non-zero value if successful. Note that the returned +value will be passed into the post_add_column so temporary values can be passed +through if required. + +post_add_column accepts $name (of column), $col (hashref of column attributes), +$results (of pre_add_column). This method is called just after the column has +been inserted into the database. + +=item pre_delete_column + +=item post_delete_column + +These previous functions are called just before and after the sql for a old +column is deleted. They must remove all objects and "things" associated with a +particular column's index. + +pre_delete_column accepts $name (of column), $col (hashref of column +attributes). The method will only be called if the column has a weight +associated with it. The function must return a non-zero value if successful. +Note that the returned value will be passed into the post_delete_column so +temporary values can be passed through if required. + +post_delete_column accepts $name (of column), $col (hashref of column +attributes), $results (of pre_add_column). This method is called just after the +column has been dropped from the database. + +=item pre_drop_table + +=item post_drop_table + +The two previous methods are used before and after the table is dropped. The +methods must remove any tables or "things" related to indexing from the table. + +pre_drop_table receives no arguments. It can find a copy of the current table +and columns associated in $self->{table}. + +post_drop_table receives one argument, which is the result of the +pre_drop_table. + +=back + +The following set of functions take place in GT::SQL::Table + +=over 2 + +=item pre_add_record + +=item post_add_record + +Called just before and after an insert occurs. These functions take the record +and indexes them as required. + +pre_add_record will receive one argument, $rec, hashref, which is the record +that will be inserted into the database. Table information can be found by +accessing $self->{table} Much like the other functions, on success the result +will be cached and fed into the post_add_record function. + +post_add_record receives $rec, a hashref to describing the new result, the $sth +of the insert query, and the result of the pre_add_record method. The result +from $sth->insert_id if there is a ai field will be the new unique primary key. + +=item pre_update_record + +=item post_update_record + +Intercepts the update request before and just after the sql query is executed. +This override has the potential of being rather messy. More than one record can +be modified in this action and the indexer must work a lot to ensure the +database is up to snuff. + +pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is +a hashref containing the new values that must be set, and $where_cond is a +GT::SQL::Condition object selecting records to update. The result once again, is +cached and if undef is considered an error. + +post_update_record takes the same parameters as pre_update_record, except one +extra paremeter, the result of pre_update_record. + +=item pre_delete_record + +=item post_delete_record + +Called just before and after the deletion request for records are called. + +pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object +telling which records to delete. The results of this method are passed to +post_delete_record. + +post_delete_record, has one addition parameter to pre_delete_record and like +most post_ methods, is the result of the pre_delete_record method. + +=item pre_delete_all_records + +=item post_delete_all_records + +These two functions are quite simple, but they are different from drop search +driver in that though the records are all dropped, the framework for all the +indexing is not dropped as well. + +Neither function is passed any special data, except for post_delete_all_records +which receives the rsults of the pre_delete_all_records method. + +=item reindex_all + +This function is sometimes called by the user to refresh the index. The +motivation for this, in the case of the INTERNAL driver, is sometimes due to +outside manipulation of the database tables, the index can become +non-representative of the data in the tables. This method is to force the +indexing system to fix errors that have passed. + +=item ok + +This function is called by GT::SQL::Search as a package method, +GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object +reference. What this function must do is to return a true or false value that +tells the search system if this driver can be used. The MYSQL driver has a good +example for this, it tests to ensure that the mysql database system version is +at least 3.23.23. + +=back + +=head2 Structure of a Search Driver + +The Searcher is responsible for only one thing, to return results from a query +search. You can override the parser, however, subclassing the following methods +will have full parsing for all things such as +/-, string parsing and substring +matching. + +The structures passed into the methods get a little complicated so beware! + +ALL the following functions receive two parameters, the first is a search +parameters detailing the words/phrases to search for, the second parameter is +the current result set of IDs => scores. + +There are two types of search parameters, one for words and the other for +phrases. The structure is a little messy so I'll detail them here. + +For words, the structure is like the following: + + $word_search = { + 'word' => { + substring => '1', # set to 1 if this is substring match + phrase => 0, # not a phrase + keyword => 1, # is a keyword + mode => '', # can also be must, cannot to mean +/- + }, + 'word2' => ... + } + +For phrases the structure will become: + + $phrase_search => { + 'phrase' => { + substring => undef # never required + phrase => [ + 'word1', + 'word2', + 'word3', + ... + ], # for searching by indiv word if required + keyword => 0, # not a keyword + mode => '' # can also be must, cannot + }, + 'phrase2' => ... + } + +Based on these structures, hopefully it will be easy enough to build whatever is +required to grab the appropriate records. + +Finally, the second item passed in will be a hash filled with ID => score values +of search results. They look something like this: + + $results = { + 1 => 56, + 2 => 31, + 4 => 6 + } + +It is important for all the methods to take the results and return the results, +as the result set will be daisychained down like a set to be operated on by +various searching schemes. + +At the end of the query, the results in this set will be sorted and returned to +the user as an sth. + +Operations on this set are preformed by the following five methods. + +=over 2 + +=item _query + +This method is called just after all the query string has been parsed and put +into their proper buckets. This method is overridden by the INTERNAL driver to +decide it wants to switch to the NONINDEX driver for better performance. + +Two parameters are passed in, ( $input, $buckets ). $input is a hash that +contains all the form/cgi parameters passed to the $tbl->query function and +$buckets is s the structure that is created after the query string is parsed. +You may also call $self->SUPER::_query( $input, $buckets ) to pass the request +along normally. + +You must return undef or an STH from this function. + +=item _union_query + +This method takes a $word_search and does a simple match query. If it finds +records with any of the words included, it will append the results to the list. +Passed in is the $results and it must return the altered results set. + +This method must also implement substring searching. + +=item _phrase_query + +Just like the union_query, however it searches based on phrases. + +=item _phrase_intersect_query + +This takes a $phrase_search and a $result as parameters. This method must look +to find results that are found within the current result set that have the +passed phrases as well. However, if there are no results found, this method can +look for more results. + +=item _intersect_query + +Takes two parameters, a $word_search, and $results. Just like the +_phrase_intersect query, if there are results already, tries to whittle away the +result set. If there are no results, tries to look for results that have all the +keywords in a record. + +This method must also implement substring searching. + +=item _disjoin_query + +Takes two parameters, a $word_search, and $results. This will look through the +result set and remove all matches to any of the keywords. + +This method must also implement substring searching. + +=item _phrase_disjoin_query + +Two parameters, $phrase_search and $results are passed to this method. This does +the exact same thing as _disjoin_query but it looks for phrases. + +=item query + +If you choose to override this method, you will have full control of the query. + +This method accepts a $CGI or a $HASH object and performs the following + + Options: + - paging + mh : max hits + nh : number hit (or page of hits) + sb : column to sort by (default is by score) + + - searching + ww : whole word + ma : 1 => OR match, 0 => AND match, undefined => QUERY + substring : search for substrings of words + bool : 'and' => and search, 'or' => or search, '' => regular query + query : the string of things to ask for + + - filtering + field_name : value # Find all rows with field_name = value + field_name : ">value" # Find all rows with field_name > value. + field_name : " value. + field_name-lt : value # Find all rows with field_name < value. + +The function must return a STH object. However, you may find useful the +GT::SQL::Search::STH object, which will automatically handle mh, nh, and +alternative sorting requests. All you will have to do is + + sub query { ... your code ... return $self->sth( $results ); } + +Where results is a hashref containing primarykeyvalue => scorevalues. + +=item alternate_driver_query + +There is no reason to override this method, however, if you would like to use +another driver's search instead of the current, this method will let you do so. + +Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name +of the driver you'd like to use and $input is the parameters passed to the +method. Returned is an $sth value (undef if an error has occurred). This method +was used in the INTERNAL driver to shunt to NONINDEXED if it found the search +would take too long. + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Common.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Common.pm new file mode 100644 index 0000000..30e4011 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Common.pm @@ -0,0 +1,82 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Common +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# +package GT::SQL::Search::Base::Common; + +use strict; +use Exporter; +use vars qw/ @ISA @EXPORT $STOPWORDS /; + + @ISA = qw( Exporter ); + @EXPORT = qw( &_tokenize &_check_word $STOPWORDS ); + + $STOPWORDS = { map { $_ => 1 } qw/ + of about or all several also she among since an some and such are than + as that at the be them because there been these between they both this + but those by to do toward during towards each upon either for from was + had were has what have when he where her which his while however with if + within in would into you your is it its many more most must on re it + test not above add am pm jan january feb february mar march apr april + may jun june jul july aug august sep sept september oct october nov + november dec december find & > < we http com www inc other + including + / }; + +sub _tokenize { +#-------------------------------------------------------------------------------- +# takes a strings and chops it up into little bits + my $self = shift; + my $text = shift; + my ( @words, $i, %rejected, $word, $code ); + +# split on any non-word (includes accents) characters + @words = split /[^\w\x80-\xFF\-]+/, lc $text; + $self->debug_dumper( "Words: ", \@words ) if ($self->{_debug}); + +# drop all words that are too small, etc. + $i = 0; + while ( $i <= $#words ) { + $word = $words[ $i ]; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + splice( @words, $i, 1 ); + $rejected{$word} = $self->{'rejections'}->{$code}; + } + else { + $i++; # Words ok. + } + } + $self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug}); + $self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug}); + + return ( \@words, \%rejected ); +} + +sub _check_word { +#-------------------------------------------------------------------------------- +# Returns an error code if it is an invalid word, otherwise returns nothing. +# + my $self = shift; + my $word = shift; + my $code; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + return $code; + } + return; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Indexer.pm new file mode 100644 index 0000000..1fed440 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Indexer.pm @@ -0,0 +1,78 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# +# + +package GT::SQL::Search::Base::Indexer; + + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/GT::Base GT::SQL::Search::Base::Common/; + $ATTRIBS = { + driver => undef, + stopwords => $STOPWORDS, + rejections => { + STOPWORD => "is a stopword", + TOOSMALL => "is too small a word", + TOOBIG => "is too big a word" + }, + table => '', + init => 0, + debug => 0, + min_word_size => 3, + max_word_size => 50, + }; + +sub drop_search_driver { 1 } +sub add_search_driver { 1 } + +# found in GT::SQL::Creator +sub pre_create_table { 1 } +sub post_create_table { 1 } + +# GT::SQL::Editor +sub pre_add_column { 1 } +sub post_add_column { 1 } + +sub pre_delete_column { 1 } +sub post_delete_column { 1 } + +sub pre_drop_table { 1 } +sub post_drop_table { 1 } + +# GT::SQL::Table +sub pre_add_record { 1 } +sub post_add_record { 1 } + +sub pre_update_record { 1 } +sub post_update_record { 1 } + +sub pre_delete_record { 1 } +sub post_delete_record { 1 } + +sub pre_delete_all_records { 1 } +sub post_delete_all_records { 1 } + +sub driver_ok { 1 } + +sub reindex_all { 1 } + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/STH.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/STH.pm new file mode 100644 index 0000000..53a051d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/STH.pm @@ -0,0 +1,287 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::STH +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::STH; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /; + use GT::Base; + + @ISA = ('GT::Base'); + $ATTRIBS = { + '_debug' => 0, + 'sth' => undef, + 'results' => {}, + 'db' => undef, + 'table' => undef, + 'index' => 0, + 'order' => [], + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'nh' => 0, + 'mh' => 0 + }; + $ERROR_MESSAGE = 'GT::SQL'; + $ERRORS = { + BADSB => 'Invalid character found in so: "%s"', + }; + +sub init { +#-------------------------------------------------------------------------------- + my $self = shift; + +# setup the options + $self->set(@_); + +# correct a few of the values + --$self->{nh} if $self->{nh}; + + my $sth; + my $results = $self->{results}; + $self->{rows} = scalar( $results ? keys %{$results} : 0 ); + +# if we have asked to have sorting by another column (non score), create the part of the query that handles taht + $self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug}); + my $sb; + +# clean up the sort by columns. + unless ($self->{'score_sort'}) { + $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so}); + } + +# setup the max hits and the offsets + $self->{index} = $self->{nh} * $self->{mh} || 0; + $self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned. + + if ( $self->{max_index} > $self->{rows} ) { + $self->{max_index} = $self->{rows}; + $self->{rows} = $self->{rows} - $self->{index}; + $self->{rows} < 0 ? $self->{rows} = 0 : 0; + } + + else { + $self->{rows} = $self->{mh}; + } + +# if we are sorting by another column, handle that + if ( $sb and (keys %{$self->{results}})) { + my ( $table, $pk ) = $self->_table_info(); + my ( $query, $where, $st, $limit ); + + $where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')'; + $self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!; + $query = qq! + SELECT $pk + FROM $table + WHERE $where + $sb + $limit + !; + $self->debug( "Row fetch query: $query" ) if ($self->{_debug}); + $sth = $self->{table}->{driver}->prepare( $query ); + $sth->execute(); + +# fix the counts + $self->{index} = 0; + $self->{max_hits} = $self->{rows}; + +# now return them + my $order = $sth->fetchall_arrayref(); + $sth->finish(); + + $self->{'order'} = [ map { $_->[0] } @{$order} ]; + } + else { + $self->{'order'} = [ sort { + ( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 ) + } keys %{$results} ]; + $self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug}); + } + +} + +sub cache_results { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my ($sth, @records, $i, %horder, @order, $in_list); + my $table = $self->{table}; + my $tname = $table->name(); + my ($pk) = $self->{table}->pk; + + use GT::SQL::Condition; + +# we know what we're doing here so shut off warns (complains about uninit'd values in range +# if thee aren't enough elements in the order array) + my $w = $^W; $^W = 0; + @order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return []; + $^W = $w; + + $i = 0; %horder = ( map { ( $_ => $i++) } @order ); + $in_list = join ( ",", @order ); + my $query = qq| + SELECT * + FROM + $tname + WHERE + $pk IN($in_list) + |; + +# the following is left commented out as... +# if $tbl->select is used $table->hits() will not +# return an accurate count of the number of all the hits. instead, will return +# a value up to mh. $tbl->hits() is important because the value is used +# in toolbar calculations +# +# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) ); + $sth = $table->do_query( $query ); + + while ( my $href = $sth->fetchrow_hashref() ) { + $records[$horder{$href->{$pk}}] = \%$href + } + + return \@records; + +} + +sub fetchrow_array { +#-------------------------------------------------------------------------------- + return @{ $_[0]->fetchrow_arrayref() || [] }; +} + +sub fetchrow_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + my $records = $self->{cache} ||= $self->cache_results; + my $href = shift @$records or return; + return $self->_hash_to_array($href); +} + +sub fetchrow_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my $records = $self->{cache} ||= $self->cache_results; + my $table = $self->{table}; + my ($pk) = $self->{table}->pk; + + my $href = shift @$records or return; + + $href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} ); + + return $href; + +} + +sub fetchall_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + my @results; + while (my $res = $self->fetchrow_hashref) { + push @results, $res; + } + return \@results; +} + +sub fetchall_list { +#-------------------------------------------------------------------------------- + return { map { @$_ } @{shift->fetchall_arrayref} } +} + +sub fetchall_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + + $self->{order} or return []; + my $results = $self->{results}; + my ($pk) = $self->{table}->pk; + my $scol = $self->{score_col}; + + + if (!$self->{allref_cache}) { + $self->{allref_cache} ||= $self->cache_results; + + for my $i ( 0 .. $#{$self->{allref_cache}} ) { + my $element = $self->{allref_cache}->[$i]; + if ( $_[0] eq 'HASH' ) { + $element->{$scol} = $results->{$element->{$pk}}; + } + else { + $element->{$scol} = $self->_hash_to_array( $element->{$scol} ); + } + }; + } + + my $records = $self->{allref_cache}; + + return $records; +} + +sub score { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{score}; +} + +sub _hash_to_array { +#-------------------------------------------------------------------------------- + my $self = shift; + my $href = shift or return; + + my $results = $self->{'results'}; + my $table = $self->{table}; + my $cols = $table->cols(); + my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] ); + my ($pk) = $self->{table}->pk; + my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ]; + + return $aref; +} + +sub rows { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{rows}; +} + +sub _table_info { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my ($pk) = $self->{table}->pk; + return ( $table, $pk ); +} + +sub DESTROY { +#-------------------------------------------------------------------------------- + my $self = shift; + $self->{'sth'} and $self->{'sth'}->finish(); +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Search.pm new file mode 100644 index 0000000..f16d559 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/Search.pm @@ -0,0 +1,572 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# + +package GT::SQL::Search::Base::Search; + + + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + @ISA = qw( GT::Base GT::SQL::Search::Base::Common); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/ GT::Base /; + + $ATTRIBS = { + 'stopwords' => $STOPWORDS, + 'mh' => 25, + 'nh' => 1, + 'ww' => undef, + 'ma' => undef, + 'bool' => undef, + 'substring' => 0, + 'query' => '', + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'debug' => 0, + '_debug' => 0, + +# query related + 'db' => undef, + 'table' => undef, + 'filter' => undef, + 'callback' => undef, + +# strict matching of indexed words, accents on words do count + 'sm' => 0, + 'min_word_size' => 3, + 'max_word_size' => 50, + }; + +sub init { +#-------------------------------------------------------------------------------- +# Initialises the Search object +# + my $self = shift; + my $input = $self->common_param(@_); + + $self->set($input); + +# now handle filters..., + my $tbl = $self->{table}; + my $cols = $tbl->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + exists $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if ( keys %filters ) { + $self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} ); + $self->filter(\%filters); + } + + $self->{table}->connect; +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query..., + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{'rejected_keywords'} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = &_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + return $self->_query($input, $buckets); +} + +sub _query { +#-------------------------------------------------------------------------------- + my ( $self, $input, $buckets ) = @_; + +# now handle the separate possibilities + my $results = {}; + +# query can have phrases + $results = $self->_phrase_query( $buckets->{phrases}, $results ); + $self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query have keywords + $results = $self->_union_query( $buckets->{keywords}, $results ); + $self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have phrases + $results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results ); + $self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have keywords + $results = $self->_intersect_query( $buckets->{keywords_must}, $results ); + $self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have keywords + $results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results ); + $self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have phrases + $results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results); + $self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $results = $self->filter(\%filters, $results); + } + elsif ($self->{filter}) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $results = $self->_filter_query( $self->{filter}, $results ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll dothat here + $self->{filter} = undef; + +# now run through a callback function if needed. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + $self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + } + +# so how many hits did we get? + $self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) ); + +# and now create a search sth object to handle all this + return $self->sth( $results ); +} + +sub sth { +#-------------------------------------------------------------------------------- + my $self = shift; + my $results = shift; + + require GT::SQL::Search::Base::STH; + my $sth = GT::SQL::Search::STH->new( + 'results' => $results, + 'db' => $self->{table}->{driver}, +# pass the following attributes down to the STH handler + map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /) + ); + + return $sth; +} + +sub rows { +#-------------------------------------------------------------------------------- +# after a query is run, returns the number of rows + my $self = shift; + return $self->{rows} || 0; +} + +sub _add_filters { +#-------------------------------------------------------------------------------- +# creates the filter object + my $self = shift; + my $filter; + +# find out how we're calling the parameters + if ( ref $_[0] eq 'GT::SQL::Condition' ) { + $filter = shift; + } + elsif ( ref $_[0] eq 'HASH' ) { + + +# setup the query condition using the build_query condition method +# build the condition object + my %opts = %{ shift() || {} }; + delete $opts{query}; + + $filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} ); + + } + else { + return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter"); + } + +# Use ref, as someone can pass in filter => 1 and mess things up. + + ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter); + $self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug}); + + return $self->{filter}; + +} + +sub _preset_options { +#-------------------------------------------------------------------------------- +# sets up word parameters + my $self = shift; + my $query = shift or return; + my $input = shift or return $query; + +# whole word searching + if ( defined $input->{'ww'} or defined $self->{'ww'}) { + if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; } + } + } + +# substring searching + if ( defined $input->{'substring'} or defined $self->{'substring'}) { + if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) { + for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; } + } + } + + if ( defined $input->{'ma'} or defined $self->{'ma'} ) { +# each keyword must be included + if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } +# each word can be included but is not necessary + else { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + +# some more and or searches, only if user hasn't put +word -word + if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } + } + elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + + return $query; +} + +sub _phrase_query { $_[1] } +sub _union_query { $_[1] } +sub _phrase_intersect_query { $_[1] } +sub _intersect_query { $_[1] } +sub _disjoin_query { $_[1] } +sub _phrase_disjoin_query { $_[1] } + +sub filter { +#-------------------------------------------------------------------------------- +# adds a filter +# + my $self = shift; + +# add filters.., + my $filters = $self->_add_filters( shift ); + my $results = shift; + +# see if we need to execute a search, otherwise just return the current filterset + defined $results or return $results; + +# start doing the filter stuff + return $self->_filter_query( $filters, $results ); +} + +sub _parse_query_string { +#------------------------------------------------------------ +# from Mastering Regular Expressions altered a fair bit +# takes a space delimited string and breaks it up. +# + my $self = shift; + my $text = shift; + + my %words = (); + my %reject = (); + my %mode = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# work on the individual elements + my @new = (); + while ( $text =~ m{ + # the first part groups the phrase inside the quotes. + # see explanation of this pattern in MRE + ([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ? + | (\+?[\w\x80-\xFF\-\*]+),? + | ' ' + }gx ) { + + my $match = lc $+; + +# strip out buffering spaces + $match =~ s/^\s+//; $match =~ s/\s+$//; + +# don't bother trying if there is nothing there + next unless $match; + +# find out the searching mode + my ($mode, $substring, $phrase); + if (my $m = $mode{substr($match,0,1)}) { + $match = substr($match,1); + $mode = $m; + } + +# do we need to substring match? + if ( substr( $match, -1, 1 ) eq "*" ) { + $match = substr($match,0,length($match)-1); + $substring = 1; + } + +# find out if we're dealing with a phrase + if ( substr($match,0,1) eq '"' ) { + $self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug}); + + $match = substr($match,1); + +# however, we want to make sure it's a phrase and not something else + my ( $word_list, $rejected ) = $self->_tokenize( $match ); + $self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug}); + $self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug}); + my $word_count = @$word_list; + + if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase + elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase + } + +# make sure we can use this word + if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) { + $reject{ $match } = $code; + next; + } + +# now, see if we should toss this word + $words{$match} = { + mode => $mode, + phrase => $phrase, + substring => $substring, + keyword => not $phrase, + }; + } + +# words is a hashref of: +# { +# word => { +# paramaters => 'values' +# }, +# word1 => { +# ... +# }, +# ... +# } +# + return( \%words, \%reject ); + +} + + +sub _filter_query { +#-------------------------------------------------------------------------------- +# get the results from the filter +# + my $self = shift; + my $filters = shift; + my $results = shift or return {}; + keys %{$results} or return $results; + + my $table = $self->{table}; + my $tname = $table->name(); + +# setup the where clause + my $where = $filters->sql() or return $results; + my ($pk) = $table->pk; + $where .= qq! AND $pk IN (! . join(',', keys %$results) . ')'; + +# now do the filter + my $query = qq! + SELECT $pk + FROM + $tname + WHERE + $where + !; + $self->debug( "Filter Query: $query" ) if ($self->{_debug}); + my $sth = $self->{table}->{driver}->prepare($query); + $sth->execute(); + +# get all the results + my $aref = $sth->fetchall_arrayref; + return { + map { + $_->[0] => $results->{$_->[0]} + } @$aref + }; +} + +sub _create_buckets { +#------------------------------------------------------------ +# takes the output from _parse_query_string and creates a +# bucket hash of all the different types of searching +# possible + my $query = shift or return; + + my %buckets; + +# put each word in the appropriate hash bucket + foreach my $parameter ( keys %{$query} ) { + + my $word_data = $query->{$parameter}; + +# the following is slower, however, done that way to be syntatically legible + if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) { + $buckets{"phrases_$1"}->{$parameter} = $word_data; + } + elsif ( $word_data->{'phrase'} ) { + $buckets{'phrases'}->{$parameter} = $word_data; + } + elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) { + $buckets{"keywords_$1"}->{$parameter} = $word_data; + } + else { + $buckets{'keywords'}->{$parameter} = $word_data; + } + + } + + return \%buckets; +} + +sub alternate_driver_query { +#-------------------------------------------------------------------------------- + my ( $self, $drivername, $input ) = @_; + + $drivername = uc $drivername; + require GT::SQL::Search; + my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername }); + my $sth = $driver->query( $input ); + foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; } + return $sth; + +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + +# Remove score attribute, used only for internal indexes. + $sb =~ s/^\s*score\b//; + $sb =~ s/,?\s*\bscore\b//; + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Indexer.pm new file mode 100644 index 0000000..f8d9293 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Indexer.pm @@ -0,0 +1,411 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::INTERNAL::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::INTERNAL::Indexer; + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Indexer->new(@_) +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $table = $self->{table}->name; + my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List"); + my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List"); + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $name = $self->{table}->name; + +# first create the table that handles the words. + my $creator = $self->{table}->creator ( $name . "_Word_List" ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Word => { + pos => 2, + type => 'varchar', + not_null=> 1, + size => '50' + }, + Frequency => { + pos => 3, + type => 'int', + not_null=> 1 + } + ); + $creator->pk('Word_ID'); + $creator->ai('Word_ID'); + $creator->unique({ $name . "_wordndx" => ['Word'] }); + $creator->create('force') or return; + +# now create the handler for scores + $creator = $self->{table}->creator( $name . '_Score_List' ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Item_ID => { + pos => 2, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Score => { + pos => 3, + type => 'int', + not_null => 1 + }, + Word_Pos => { + pos => 4, + type => 'int', + not_null => 1 + } + ); + $creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] }); + $creator->create('force') or return; + return 1; + +} + +sub post_create_table { +# ------------------------------------------------------------------------------ +# creates the index tables.. +# + return $_[0]->add_search_driver(@_); +} + +sub post_drop_table { +# ------------------------------------------------------- +# Remove the index tables. +# + return $_[0]->drop_search_driver(@_); +} + +sub init_queries { +# ------------------------------------------------------- +# Pre-load all our queries. +# + my $self = shift; + my $queries = shift; + + my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL'); + my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table_name . '_Word_List'; + my $seq = $wtable . '_seq'; + my $stable = $table_name . '_Score_List'; + + my %ai_queries = ( + ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)", + ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)", + ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)" + ); + my %queries = ( + upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?", + sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?", + sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?", + del_word => "DELETE FROM $wtable WHERE Word_ID = ?", + mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?", + ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)", + item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID", + scr_del => "DELETE FROM $stable WHERE Item_ID = ?", + dump_word => "DELETE FROM $wtable", + dump_scor => "DELETE FROM $stable" + ); + my $type = uc $self->{table}->{connect}->{driver}; + $self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"}); + +# check to see if the table exist + $self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + $self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + + + if ($type eq 'MYSQL') { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } + else { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } +} + +sub post_add_record { +# ------------------------------------------------------- +# indexes a single record + my ($self, $rec, $insert_sth ) = @_; + +# Only continue if we have weights and a primary key. + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk}; + my $index = 0; + + $self->{init} or $self->init_queries; + +# Go through each column and index it. + foreach my $column ( keys %weights ) { + my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + my $weight = $weights{$column}; + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + + return 1; +} + +sub reindex_all { +# ------------------------------------------------------- + my $self = shift; + my $table = shift; + my $opts = shift; + my $tick = $opts->{tick} || 0; + my $max = $opts->{max} || 5000; + + my %weights = $self->{table}->_weight_cols() or return; + my @weight_list = keys %weights; + my @weight_arr = map { $weights{$_} } @weight_list; + my ($pk) = $self->{table}->pk(); + my $index = 0; + my $word_id = 1; + $self->{init} or $self->init_queries; + +# first nuke the current index + $self->dump_index(); + +# Go through the table and index each field. + my $iterations = 1; + my $count = 0; + + while (1) { + if ($max) { + my $offset = ($iterations-1) * $max; + $table->select_options ( "LIMIT $offset,$max"); + } + my $cond = $opts->{cond} || {}; + my $sth = $table->select($cond, [ $pk, @weight_list] ); + my $done = 1; + + while ( my $arrayref = $sth->fetchrow_arrayref() ) { +# the primary key value + my $i = 0; + my $item_id = $arrayref->[($i++)]; + $index = 0; + $done = 0; + +# start going through the record data + foreach my $weight ( @weight_arr ) { + my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + if ($tick) { + $count++; + $count % $tick or (print "$count "); + $count % ($tick*10) or (print "\n"); + } + } + return if ($done); + $iterations++; + return if (! $max); + } +} + +sub pre_delete_record { +# ------------------------------------------------------- +# Delete a records index values. +# + my $self = shift; + my $where = shift; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $q = $tbl->select( $where, [ $pk ] ); + + while ( my $aref = $q->fetchrow_arrayref() ) { + my $item_id = $aref->[0] or next; + my @weight_list = keys %weights; + my $index = 0; + $self->{init} or $self->init_queries; + + # Get a frequency count for each word + $self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + + # Now go through and either decrement the freq, or remove the entry. + while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) { + $self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug}); + if (my $freq = $self->{sel_freq}->fetchrow_arrayref) { + if ($freq->[0] == $frequency) { + $self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + } + } + # Remove the listings from the scores table. + $self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + return 1; +} + +sub post_update_record { +# ------------------------------------------------------- + my ( $self, $set_cond, $where_cond, $tmp ) = @_; + +# delete the previous record + $self->pre_delete_record( $where_cond ) or return; +# +# the new record + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my $q = $tbl->select( $where_cond ); + while ( my $href = $q->fetchrow_hashref() ) { + $self->post_add_record( $href ); + } + + return 1; + +} + +sub reindex_record { +# ------------------------------------------------------- +# reindexes a record. basically deletes all associated records from current db abnd does an index. +# it's safe to use this + my $self = shift; + my $rec = shift; + + $self->delete_record($rec); + $self->index_record($rec); +} + +sub dump_index { +# ------------------------------------------------------- + my $self = shift; + $self->{init} or $self->init_queries; + + $self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); +} + + +sub debug_dumper { +# ------------------------------------------------------------------------------ +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )); + } +} + +sub DESTROY { +# ------------------------------------------------------------------------------ +# Calls finish on init queries. +# + my $self = shift; + return unless ($self->{init}); + $self->{upd_word}->finish; +# $self->{ins_word}->finish; will get finished automatically + $self->{sel_word}->finish; + $self->{sel_freq}->finish; + $self->{del_word}->finish; + $self->{mod_word}->finish; + $self->{ins_scor}->finish; + $self->{item_cnt}->finish; + $self->{scr_del}->finish; + $self->{dump_word}->finish; + $self->{dump_scor}->finish; + $self->{init} = 0; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Search.pm new file mode 100644 index 0000000..dd36edd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/INTERNAL/Search.pm @@ -0,0 +1,604 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Indexer +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Search::INTERNAL::Search; + +# ------------------------------------------------------------------------------ + use strict; + use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# the max number of links that can be handled by UNION before it should simply +# shunt the searching pipe to NONINDEXED system + 'union_shunt_threshold' => '5000', + 'phrase_shunt_threshold' => '1000', + }; + + +################################################################################ +# Internal functions +################################################################################ + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Search->new(@_) +} + +sub _query { +# ------------------------------------------------------------------------------ +# this just checks to ensure that the words are not all search keywords +# + my ( $self, $input, $buckets ) = @_; + +# calculate wordids and frequencies + foreach ( keys %$buckets ) { + $buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) ); + } + +# the following is a bit tricky and will be replaced however, if the number +# of results from a union is more than the maximum shunt value, it will +# simply do a nonindexed query + if ( $buckets->{keywords} ) { + my $rec = _count_frequencies( $buckets->{keywords} ); + my $count = 0; + foreach ( values %$rec ) { $count += $_; } + if ($count > $self->{union_shunt_threshold}) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + + +# Now test the phrases. Just due to how the phrase searching works, the queries +# can grow in size extremely rapidly, and slowdown the search. So the limit for +# phrase searching is separate as it requires a different cutoff value than +# the keyword search which is usually much lower! + if ($buckets->{phrases}) { + foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + if ($buckets->{phrases_must}) { + foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + return $self->SUPER::_query( $input, $buckets ); +} + +sub _count_frequencies { +# ------------------------------------------------------------------------------ + my $word_info = shift; + my $rec = {}; + foreach my $word ( keys %$word_info ) { + my $freq = 0; + foreach ( values %{$word_info->{$word}->{word_info}} ) { + $freq += $_; + } + $rec->{$word} = $freq; + } + + return $rec; +} + +sub _table_names { +# ------------------------------------------------------------------------------ +# return the table names +# + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table . '_Word_List'; + my $stable = $table . '_Score_List'; + + return ( $table, $wtable, $stable); +} + +sub _word_infos { +# ------------------------------------------------------------------------------ +# get the word ids and frequencies +# + my $self = shift; + my $word_infos = shift; + + my $rec = {}; + + foreach my $word ( keys %$word_infos ) { + my $wi = $word_infos->{$word}->{word_info}; + $rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ]; + } + + return $rec; + +} + +sub _union_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + my ( $query, $where, $db, $word_infos ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return $results; + + return $results unless (keys %{$word_infos}); + + $self->debug_dumper( "Getting words: ", $words) if ($self->{_debug}); + +# build the where clause + my @word_ids; + foreach my $word_synonym_list ( values %$word_infos ) { + next unless ( $word_synonym_list ); + foreach my $word_id ( @{$word_synonym_list }) { + next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference + push @word_ids, $word_id->[0]; # we need to shed the word quantities + } + } + + return $results unless ( @word_ids ); + $where = 'Word_ID IN(' . join(",", @word_ids) . ")"; + +# build the query + $query = qq! + SELECT Item_ID, SUM(Score) + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + + $self->debug( "Union Query: $query" ) if ($self->{_debug}); + +# prepare the query + my $sth = $db->prepare( $query ) or return; + $sth->execute() or return; + +# get the results + my %word_infos = $sth->fetchall_list; + +# merge the current result set into found + foreach my $item ( keys %{$results} ) { + $word_infos{$item} += $results->{$item}; + }; + + return \%word_infos; +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match all the keywords +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + + $words or return $results; + keys %{$words} or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + +# have we left any of our words out? + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return {}; + if ( keys %{$word_infos} < keys %{$words} ) { + return {}; + } + + $self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + + $word_hits->{$word} = $total_freq or return; + + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits}; + + $self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug}); + +# find out how we're going to handle the searching, if the first elements + +################################################################################ +### The following part is for smaller intersect subsets +################################################################################ + my $intersect = $results; + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$intersect} ) { + $where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID, SUM(Score) AS Score + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug( "Intersect Query: $query" ) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + + $self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug}); + +# go through all the matches and intersect them + my %tmp = (); + foreach my $row ( @{$matches} ) { + my ( $itemid, $score ) = @{$row}; + $intersect->{$itemid} ||= 0; + $tmp{ $itemid } = $intersect->{$itemid} + $score; + } + +# inform the system of that development + %tmp or return; + $intersect = \%tmp; + } + + return $intersect; +} + +sub _disjoin_query { +#------------------------------------------------------------ + my $self = shift; + my $words = shift; + my $results = shift || {}; + $words or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $results; + +# have we left any of our words out? + $word_infos = $self->_word_infos( $words ) or return $results; +# if ( keys %{$word_infos} < keys %{$words} ) { +# return $results; +# } + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + my $total_freq = 0; + foreach my $word_synonyms ( $word_infos->{$word} ) { + $total_freq += ( $word_synonyms->[0] || 0 ); + } +# if the value is null this mean there is actually no results, whoops! + $total_freq and $word_hits->{$word} = $total_freq; + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits}; + $self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller disjoin presets +################################################################################ + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$results} ) { + $where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug($query) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + +# strip the matches from the current result set + foreach my $word ( map { $_->[0] } @{$matches}) { + delete $results->{$word}; + } + } + + return $results; +} + +sub _phrase_disjoin_query { +#------------------------------------------------------------ +# subtracts the found phrases from the list + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform disjoin + foreach my $itemid ( keys %{$temp} ) { + $self->debug( "Deleting $itemid from list" ) if ($self->{_debug}); + delete $results->{$itemid}; + } + } + + return $results; +} + +sub _phrase_intersect_query { +#------------------------------------------------------------ +# intersects phrases together + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform intersect + foreach my $itemid ( keys %{$temp} ) { + $temp->{$itemid} += $results->{$itemid} || 0; + } + $results = $temp; + + } + + return $results; + +} + +sub _phrase_query { +#------------------------------------------------------------ +# this is a phrase union query + my $self = shift; + my $phrases = shift or return; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + $results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results ); + } + + return $results; + +} + +sub _get_phrase { +#------------------------------------------------------------ + my $self = shift; + my $wordlist= shift; + my $word_info = shift; + my $results = shift || {}; + + $wordlist or return $results; + + my ( $query, $where, $db, $word_infos, %word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + my ($pk) = $self->{table}->pk; + + $self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug}); + +# get all the word ids that we want to handle + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $word_info ) or return; + + + $self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + @{$word_infos->{$word} || []} or return; + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + +# if the value is null this mean there is actually no results, whoops! + $word_hits{$word} = $total_freq; + } + + $self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug}); + +# so now, setup the order of search + my $i = 0; + my %word_order = map { $_ => $i++ } @{$wordlist}; + my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits; + + $self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller phrases +################################################################################ +# start getting words in order of their frequency + my %matches = (); + my $index = 0; + foreach my $word ( @search_order ) { + +# setup the where clause for the individual words, firstly + if ( keys %matches ) { + my $vector = $word_order{$word} - $index; + $where = '('; + $where = + '(' . + join( + " OR ", + map( + "Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')', + keys %matches + ) + ) . + ") AND "; + } + else { + $where = ''; + } + + $where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')'; + + $query = qq! + SELECT + Item_ID, Score, Word_Pos + FROM + $stable + WHERE + $where + !; + + $self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug}); + my $sth = $db->prepare( $query ); + $sth->execute(); + + %matches = (); + + while (my $hit = $sth->fetchrow_arrayref) { + push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ]; + } + +# If there are no values stored in %matches, it means that for +# this keyword, there have been no hits based upon position. +# In that case, terminate and return a null result + keys %matches or last; + +# where were we in the string? + $index = $word_order{$word}; + } + +# now tally up all the scores and merge the new records in + foreach my $itemid ( keys %matches ) { + my $score = 0; + foreach my $sub_total ( @{$matches{$itemid}} ) { + $score += $sub_total->[1]; + } + $results->{$itemid} += $score; + } + + return $results; +} + +sub get_wordids { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $elements = shift or return; + my $mode = lc shift || 'keywords'; + + if ( $mode eq 'keywords' ) { + $elements = $self->_get_wordid($elements); + } + else { + foreach my $phrase ( keys %$elements ) { + my $results = $self->_get_wordid({ + map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}} + }); + + $elements->{$phrase}->{word_info} = $results; + } + } + + return $elements; +} + +sub _get_wordid { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $words = shift; + my $tbl = $self->{table}; + + my ( $table, $wtable, $stable) = $self->_table_names(); + + foreach my $word ( keys %$words ) { + my $query = + qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! . + quotemeta($word) . + ( $words->{$word}->{substring} ? '%' : '' ) . + "'"; + my $sth = $tbl->do_query($query) or next; + my $tmp = { $sth->fetchall_list }; + + $words->{$word}->{word_info} = $tmp; + } + + return $words; +} + +## +# Internal Use +# $self->_cgi_to_hash ($in); +# -------------------------- +# Creates a hash ref from a cgi object. +## +sub _cgi_to_hash { + my ($self, $cgi) = @_; + $cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL'); + my @keys = $cgi->param; + my $result = {}; + foreach my $key (@keys) { + my @values = $cgi->param($key); + if (@values == 1) { $result->{$key} = $values[0] } + else { $result->{$key} = \@values } + } + return $result; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Indexer.pm new file mode 100644 index 0000000..968f4d6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Indexer.pm @@ -0,0 +1,239 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::LUCENE::Indexer +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.2 2006/12/07 22:42:16 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::LUCENE::Indexer; + +# ------------------------------------------------------------------------------ +# Preamble information related to the object +use strict; +use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; +use Lucene; +use GT::SQL::Search::Base::Indexer; +use GT::TempFile; +@ISA = qw/ GT::SQL::Search::Base::Indexer /; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; +$ERRORS = { + INDEX_CORRUPT => 'Could not create an Indexer, this probably means your index is corrupted and you should rebuild it. The error was: %s', + DELETE_FAILED => 'Could not delete some records: %s' +}; +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_) +} + +sub _get_path { + my $self = shift; + my $name = $self->{table}->name; + my $tmpdir = GT::TempFile::find_tmpdir(); + my $path = $tmpdir . '/' . $name; + $path = $1 if $path =~ /(.*)/; # XXX untaint + return $path; +} + +sub _get_store { + my ($self, $create) = @_; + my $path = $self->_get_path; + return Lucene::Store::FSDirectory->getDirectory($path, $create); +} + +sub _get_indexer { + my ($self, $create) = @_; + my %weights = $self->{table}->_weight_cols() or return $self->error(NOWEIGHTS => 'WARN'); + + my ($pk) = $self->{table}->pk; + if (!$pk) { + return $self->error('NOPRIMARYKEY','WARN'); + } + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer; + my $store = $self->_get_store($create); + + my $iw; + eval { $iw = new Lucene::Index::IndexWriter($store, $analyzer, $create); }; + if ($@) { + return $self->error('INDEX_CORRUPT', 'WARN', "$@"); + } + return $iw; +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $path = $self->_get_path; + require File::Tools; + File::Tools::deldir($path); + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + $self->_get_indexer(1) or return; + return 1; +} + +sub post_create_table { +# ------------------------------------------------------------------------------ +# creates the index tables.. +# + return $_[0]->add_search_driver(@_); +} + +sub post_drop_table { +# ------------------------------------------------------- +# Remove the index tables. +# + return $_[0]->drop_search_driver(@_); +} + + +sub post_add_record { +# ------------------------------------------------------- +# indexes a single record + my ($self, $rec, $insert_sth, $no_optimize) = @_; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + + my $indexer = $self->_get_indexer(0) or return $self->{_debug} ? () : 1; + my $doc = new Lucene::Document; + my ($pk) = $self->{table}->pk; + delete $weights{$pk}; + for my $column_name (keys %weights) { + my $field = Lucene::Document::Field->UnStored($column_name, $rec->{$column_name}); + $field->setBoost($weights{$column_name}); + $doc->add($field); + } + $doc->add(Lucene::Document::Field->Keyword($pk, ($tbl->ai && $insert_sth ? $insert_sth->insert_id : $rec->{$pk}))); + $indexer->addDocument($doc); + $indexer->optimize if !$no_optimize; + $indexer->close; + undef $indexer; + return 1; +} + +sub reindex_all { +# ------------------------------------------------------- + my $self = shift; + my $table = shift; + my $opts = shift; + my $tick = $opts->{tick} || 0; + my $max = $opts->{max} || 5000; + + my $indexer = $self->_get_indexer(1) or return $self->{_debug} ? () : 1; # clobbers the old one + $indexer->close; + undef $indexer; + + my %weights = $self->{table}->_weight_cols() or return; + my @weight_list = keys %weights; + my ($pk) = $self->{table}->pk(); + +# Go through the table and index each field. + my $iterations = 1; + my $count = 0; + + while (1) { + if ($max) { + my $offset = ($iterations-1) * $max; + $table->select_options("LIMIT $offset,$max"); + } + my $cond = $opts->{cond} || {}; + my $sth = $table->select($cond, [$pk, @weight_list]); + my $done = 1; + + while (my $rec = $sth->fetchrow_hashref() ) { + $self->post_add_record($rec, undef, 1); + $done = 0; + if ($tick) { + $count++; + $count % $tick or (print "$count "); + $count % ($tick*10) or (print "\n"); + } + } + last if $done; + $iterations++; + last if !$max; + } + $indexer = $self->_get_indexer(0) or return; + $indexer->optimize; + $indexer->close; + undef $indexer; + return 1; +} + +sub pre_delete_record { +# ------------------------------------------------------- +# Delete a records index values. +# + my ($self, $where) = @_; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my ($pk) = $tbl->pk(); + my $q = $tbl->select($where, [$pk]); + + my $reader = eval { Lucene::Index::IndexReader->open($self->_get_store(0)); }; + if ($@) { + return $self->{_debug} ? $self->error('INDEX_CORRUPT', 'WARN', "$@") : 1; + } + + my @errors; + while (my ($item_id) = $q->fetchrow) { + my $t = new Lucene::Index::Term($pk => $item_id); + eval { $reader->deleteDocuments($t); }; + if ($@) { + push @errors, "$@"; + } + } + $reader->close; + undef $reader; + if (@errors) { + return $self->{_debug} ? $self->error('DELETE_FAILED', 'WARN', join(", ", @errors)) : 1; + } + return 1; +} + +sub post_update_record { +# ------------------------------------------------------- + my ( $self, $set_cond, $where_cond, $tmp ) = @_; + +# delete the previous record + eval { + $self->pre_delete_record($where_cond) or return $self->{_debug} ? () : 1; + }; +# +# the new record + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my ($pk) = $tbl->pk(); + my %weights = $self->{table}->_weight_cols(); + my @weight_list = keys %weights; + my $q = $tbl->select($where_cond, [$pk, @weight_list]); + while (my $href = $q->fetchrow_hashref) { + $self->post_add_record($href); + } + + return 1; + +} + +sub reindex_record { +# ------------------------------------------------------- +# reindexes a record. basically deletes all associated records from current db abnd does an index. +# it's safe to use this + my ($self, $rec) = @_; + + $self->delete_record($rec); + $self->index_record($rec); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Lucene.txt b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Lucene.txt new file mode 100644 index 0000000..36e464a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Lucene.txt @@ -0,0 +1,206 @@ +NAME + Lucene -- API to the C++ port of the Lucene search engine + +SYNOPSIS + Initialize/Empty Lucene index + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer(); + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 1); + + my $tmp_writer = new Lucene::Index::IndexWriter($store, $analyzer, 1); + $tmp_writer->close; + undef $tmp_writer; + + Choose your Analyzer (string tokenizer) + # lowercases text and splits it at non-letter characters + my $analyzer = Lucene::Analysis::SimpleAnalyzer(); + # same as before and removes stop words + my $analyzer = Lucene::Analysis::StopAnalyzer(); + # splits text at whitespace characters + my $analyzer = Lucene::Analysis::WhitespaceAnalyzer(); + # lowercases text, tokenized it based on a grammer that + # leaves named authorities intact (e-mails, company names, + # web hostnames, IP addresses, etc) and removed stop words + my $analyzer = Lucene::Analysis::Standard::StandardAnalyzer(); + + Choose your Store (storage engine) + # in-memory storage + my $store = new Lucene::Store::RAMDirectory(); + # disk-based storage + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0); + + Open and configure an IndexWriter + my $writer = new Lucene::Index::IndexWriter($store, $analyzer, 0); + # optional settings for power users + $writer->setMergeFactor(100); + $writer->setUseCompoundFile(0); + $writer->setMaxFieldLength(255); + $writer->setMinMergeDocs(10); + $writer->setMaxMergeDocs(100); + + Create Documents and add Fields + my $doc = new Lucene::Document; + # field gets analyzed, indexed and stored + $doc->add(Lucene::Document::Field->Text("content", $content)); + # field gets indexed and stored + $doc->add(Lucene::Document::Field->Keyword("isbn", $isbn)); + # field gets just stored + $doc->add(Lucene::Document::Field->UnIndexed("sales_rank", $sales_rank)); + # field gets analyzed and indexed + $doc->add(Lucene::Document::Field->UnStored("categories", $categories)); + + Add Documents to an IndexWriter + $writer->addDocument($doc); + + Optimize your index and close the IndexWriter + $writer->optimize(); + $writer->close(); + undef $writer; + + Delete Documents + my $reader = Lucene::Index::IndexReader->open($store); + my $term = new Lucene::Index::Term("isbn", $isbn); + $reader->deleteDocuments($term); + $reader->close(); + undef $reader; + + Query index + # initalize searcher and parser + my $analyzer = Lucene::Analysis::SimpleAnalyzer(); + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0); + my $searcher = new Lucene::Search::IndexSearcher($store); + my $parser = new Lucene::QueryParser("default_field", $analyzer); + + # build a query on the default field + my $query = $parser->parse("perl"); + + # build a query on another field + my $query = $parser->parse("title:cookbook"); + + # define a sort on one field + my $sortfield = new Lucene::Search::SortField("unixtime"); + my $reversed_sortfield = new Lucene::Search::SortField("unixtime", 1); + my $sort = new Lucene::Search::Sort($sortfield); + + # define a sort on two fields + my $sort = new Lucene::Search::Sort($sortfield1, $sortfield2); + + # use Lucene's INDEXORDER or RELEVANCE sort + my $sort = Lucene::Search::Sort->INDEXORDER; + my $sort = Lucene::Search::Sort->RELEVANCE; + + # query index and get results + my $hits = $searcher->search($query); + my $sorted_hits = $searcher->search($query, $sort); + + # get number of results + my $num_hits = $hits->length(); + + # get fields and ranking score for each hit + for (my $i = 0; $i < $num_hits; $i++) { + my $doc = $hits->doc($i); + my $score = $hits->score($i); + my $title = $doc->get("title"); + my $isbn = $doc->get("isbn"); + } + + # free memory and close searcher + undef $hits; + undef $query; + undef $parser; + undef $analyzer; + $searcher->close(); + undef $fsdir; + undef $searcher; + } + + Close your Store + $store->close; + undef $store; + +DESCRIPTION + Like it or not Apache Lucene has become the de-facto standard for + open-source high-performance search. It has a large user-base, is well + documented and has plenty of committers. Unfortunately Apache Lucene is + entirely written in Java and therefore of relatively little use for perl + programmers. Fortunately in the recent years a group of C++ programmers + led by Ben van Klinken decided to port Java Lucene to C++. + + The purpose of the module is to export the C++ Lucene API to perl and at + the same time be as close as possible to the original Java API. This has + the combined advantage of providing perl programmers with a + well-documented API and giving them access to a C++ search engine + library that is supposedly faster than the original. + +CHARACTER SUPPORT + Currently only ISO 8859-1 (Latin-1) characters are supported. Obviously + this included all ASCII characters. + +INDEX COMPATIBLITY + For the moment indices produced by this module are not compatible with + those from Apache Lucene. The reason for this is that this module uses + 1-byte character encoding as opposed to 2-byte (widechar) encoding with + Apache Lucene. + +INSTALLATION + This module requires the clucene library to be installed. The best way + to get it is to go to the following page + + http://sourceforge.net/projects/clucene/ + + and download the latest STABLE clucene-core version. Currently it is + clucene-core-0.9.15. Make sure you compile it in ASCII mode and install + it in your standard library path. + + On a Linux platform this goes as follows: + + wget http://kent.dl.sourceforge.net/sourceforge/clucene/clucene-core-0.9.15.tar.gz + cd clucene-core-0.9.15 + ./autogen.sh + ./configure --disable-debug --prefix=/usr --exec-prefix=/usr --enable-ascii + make + make check + (as root) make install + + To install the perl module itself, run the following commands: + + perl Makefile.PL + make + make test + (as root) make install + +AUTHOR + Thomas Busch + +COPYRIGHT AND LICENSE + Copyright (c) 2006 Thomas Busch + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + +SEE ALSO + Plucene - a pure-Perl implementation of Lucene + + KinoSearch - a search engine library inspired by Lucene + +DISCLAIMER OF WARRANTY + BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY + FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN + OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES + PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER + EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE + ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH + YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL + NECESSARY SERVICING, REPAIR, OR CORRECTION. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR + REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE + TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE + SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING + RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A + FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF + SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH + DAMAGES. + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/STH.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/STH.pm new file mode 100644 index 0000000..e9af838 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/STH.pm @@ -0,0 +1,115 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::STH +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# CVS Info : 087,071,086,086,085 +# $Id: STH.pm,v 1.1 2006/12/07 07:04:51 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::LUCENE::STH; +#-------------------------------------------------------------------------------- +use strict; +use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /; +require GT::SQL::Search::Base::STH; + +@ISA = ('GT::SQL::Search::STH'); +$ATTRIBS = { + 'db_sort' => 1, + 'hits' => undef +}; +$ERROR_MESSAGE = 'GT::SQL::Search::STH'; + + + +sub init { +#-------------------------------------------------------------------------------- +# GT::SQL::Search::STH expects a full set of results in $self->{results}. For +# Lucene the only time a full set of results is there is when we are sorting +# on a field that is not weighted, otherwise the results in $self->{results} is +# the proper page and number of results. + my $self = shift; + + $self->set(@_); + + --$self->{nh} if $self->{nh}; + + # Here we allow hits to override our concept of rows. This is only useful + # when !$self->{db_sort} + $self->{rows} = $self->{hits} + ? $self->{hits} + : $self->{results} + ? scalar(keys %{$self->{results}}) + : 0; + + if ($self->{db_sort}) { + $self->get_db_sorted_results; + } + else { + $self->get_sorted_results; + } +} + +sub get_sorted_results { +# Just sorts the results out of $self->{results} which should have been setup +# by a search driver + my ($self) = @_; + my $results = $self->{results}; + $self->{index} = 0; + $self->{max_index} = $self->{mh} - 1; + $self->{'order'} = [ sort { + ( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 ) + } keys %{$results} ]; + $self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug}); +} + +sub get_db_sorted_results { +# This assumes $self->{results} has a full result set, i.e. without any LIMIT +# It then selects the result set using the SQL driver to do the sorting. This +# is for Search modules which can not handle their own sorting + my ($self) = @_; + + my $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so}); + $self->{index} = $self->{nh} * $self->{mh} || 0; + $self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned. + if ($self->{max_index} > $self->{rows}) { + $self->{max_index} = $self->{rows}; + $self->{rows} = $self->{rows} - $self->{index}; + $self->{rows} < 0 ? $self->{rows} = 0 : 0; + } + + else { + $self->{rows} = $self->{mh}; + } + my ( $table, $pk ) = $self->_table_info(); + my ( $query, $where, $st, $limit ); + + $where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')'; + $self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!; + $query = qq! + SELECT $pk + FROM $table + WHERE $where + $sb + $limit + !; + $self->debug( "Row fetch query: $query" ) if ($self->{_debug}); + my $sth = $self->{table}->{driver}->prepare( $query ); + $sth->execute(); + + $self->{index} = 0; + $self->{max_hits} = $self->{rows}; + + # Fetch the results in sorted order + my $order = $sth->fetchall_arrayref(); + $sth->finish(); + + $self->{'order'} = [ map { $_->[0] } @{$order} ]; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Search.pm new file mode 100644 index 0000000..89fea7a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/LUCENE/Search.pm @@ -0,0 +1,260 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::LUCENE::Search +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.2 2006/12/07 22:42:16 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::LUCENE::Search; +# ------------------------------------------------------------------------------ +use strict; +use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS $ERRORS $ERROR_MESSAGE /; +use Lucene; +use GT::TempFile; +use GT::SQL::Search::LUCENE::STH; +use GT::SQL::Search::Base::Search; +@ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; +$ERRORS = { + SEARCH_ERROR => "Error searching: %s", + QUERY_ERROR => "Query error: %s" +}; +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + shift; + return GT::SQL::Search::LUCENE::Search->new(@_) +} + +sub _get_path { + my $self = shift; + my $name = $self->{table}->name; + my $tmpdir = GT::TempFile::find_tmpdir(); + my $path = $tmpdir . '/' . $name; + $path = $1 if $path =~ /(.*)/; # XXX untaint + return $path; +} + +sub _get_store { + my ($self, $create) = @_; + my $path = $self->_get_path; + return Lucene::Store::FSDirectory->getDirectory($path, $create); +} + +sub query { +# -------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# create an easily accessible argument hash + my $args = $self->common_param(@_); + my $tbl = $self->{table}; + +# see if we can setup the filtering constraints + my $filter = { %$args }; + my $query = delete $args->{query} || $self->{query} || ''; + my $ftr_cond; + +# parse query + $self->debug( "Search Query: $query" ) if ($self->{_debug}); + + my ( $query_struct, $rejected ) = $self->_parse_query_string( $query ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query_struct = $self->_preset_options( $query_struct, $args ); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + +# with the buckets, it's now possible to create a query string +# that can be passed directly into the Lucene search. + my $query_string = ''; + + foreach my $search_type ( keys %$buckets ) { + my $bucket = $buckets->{$search_type}; + foreach my $token ( keys %$bucket ) { + next unless $token; + my $properties = $bucket->{$token} or next; + $token =~ s/(["()])/\\$1/g; + $token =~ s/\b(or|and)\b/ /g; + + my $e = ' '; + +# handle boolean operations + $properties->{mode} ||= ''; + if ( $properties->{mode} eq 'must' ) { + $e .= '+'; + } + elsif ( $properties->{mode} eq 'cannot' ) { + $e .= '-'; + } + +# deal with phrase vs keyword + if ( $properties->{phrase} ) { + $e .= '"' . $token . '"' unless $token =~ /^"|"$/; + } + else { + $e .= $token; + +# substring match + if ($properties->{mode} ne 'substring') { + $e .= '*' if $properties->{substring}; + } + } + + $query_string .= $e; + } + } + +# calculate the cursor constraints + foreach my $k (qw( nh mh so sb )) { + next if defined $args->{$k}; + $args->{$k} = $self->{$k} || ''; + } + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25; + $args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score'; + + # Score is the default + $args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)(?:end)?$/i) ? lc($1) : 'asc'; + + my %weights = $tbl->_weight_cols(); + my @sortfields; + my $do_mysql_sort = 0; + for (ref($args->{sb}) eq 'ARRAY' ? @{$args->{sb}} : $args->{sb}) { + if (!exists $weights{$_}) { + $do_mysql_sort = 1 if $_ ne 'score'; + next; + } + push @sortfields, new Lucene::Search::SortField($_, $args->{so} ne 'asc'); + } + my $sort = @sortfields ? new Lucene::Search::Sort(@sortfields) : Lucene::Search::Sort->RELEVANCE; + my $store = $self->_get_store(0); + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer; + my $searcher = eval { new Lucene::Search::IndexSearcher($store); }; + if ($@) { + $self->{_debug} and $self->error('SEARCH_ERROR', 'WARN', "$@"); + return $self->sth({}, 0); # no hits + } + # Random default field, it's not used + my $parser = new Lucene::MultiFieldQueryParser((keys %weights)[0], $analyzer); + my $pquery = eval { $parser->parse($query_string, [keys %weights], $analyzer); }; + if ($@) { + $self->{_debug} and $self->error('QUERY_ERROR', 'WARN', "$@"); + return $self->sth({}, 0); # no hits + } + my $hits = $searcher->search($pquery, $sort); + my $num_hits = $hits->length; + +## Setup a limit only if there is no callback. The callback argument requires a full results list + my ($offset, $max_hits) = (0, $num_hits); + unless ($self->{callback} or $do_mysql_sort) { + $offset = ( $args->{nh} - 1 ) * $args->{mh}; + $max_hits = $offset + $args->{mh}; + } + $max_hits = $num_hits if $max_hits > $num_hits; + my ($pk) = $self->{table}->pk; + my @indexes; + my $results = {}; + for (my $i= $offset; $i < $max_hits; ++$i) { + my $doc = $hits->doc($i); + my $value = $doc->get($pk); + my $score = $hits->score($i); + $results->{$value} = $score; + } + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + $cols->{$tmp} ? ($_ => $args->{$_}) : () + } keys %{$args}; + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $results = $self->filter(\%filters, $results); + } + elsif ($self->{filter}) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $results = $self->_filter_query( $self->{filter}, $results ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll dothat here + $self->{filter} = undef; + +# now run through a callback function if needed. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + $self->{_debug} and $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + return $self->sth({}, 0); # no hits + } + $self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + } + + $self->{rows} = $num_hits; + + return $self->sth($results, $do_mysql_sort); +} + +sub sth { +#-------------------------------------------------------------------------------- + my ($self, $results, $db_sort) = @_; + + my $sth = GT::SQL::Search::LUCENE::STH->new( + 'results' => $results, + 'hits' => $self->{rows}, + 'db' => $self->{table}->{driver}, + 'db_sort' => $db_sort, +# pass the following attributes down to the STH handler + map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /) + ); + + return $sth; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Indexer.pm new file mode 100644 index 0000000..75798ae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Indexer.pm @@ -0,0 +1,98 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Indexer +# Author: Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.6 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Supports MS SQL full text indexer on MS SQL 2000 only. +# + +package GT::SQL::Search::MSSQL::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/; + + $ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MSSQLNONSUPPORT => 'You must be using MS SQL 2000 in order to use full text indexing. Current Database: %s', + CREATEINDEX => 'Problem Creating Full Text Index: %s' + }; + $ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +#-------------------------------------------------------------------------------- + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'ODBC') { + return $class->error ('MSSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + return 1; +} + +sub drop_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + + my $res = eval { + $table->do_query(" sp_fulltext_table '$name', 'drop' "); + $table->do_query(" sp_fulltext_catalog '$cat', 'drop' "); + 1; + }; + $res ? return 1 : return; +} + +sub add_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + my %weights = $table->weight; + my ($pk) = $table->pk; + +# Enable a database for full text indexing + $table->do_query(" sp_fulltext_database 'enable' ") or $self->error('CREATEINDEX', 'FATAL', $GT::SQL::error); +# Create a full text catalog to store the data. + $table->do_query(" sp_fulltext_catalog '$cat', 'create' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Make a unique index on primary key (not sure why it isn't by default. + $table->do_query(" create unique index PK_$name on $name ($pk) "); +# Mark this table as using the full text catalog created + $table->do_query(" sp_fulltext_table '$name', 'create', '$cat', 'PK_$name' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Specify which columns are to be indexed + foreach my $col (keys %weights) { + if ($weights{$col}) { + $table->do_query(" sp_fulltext_column '$name', '$col', 'add' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + } + } +# Must have a timestamp field. + $table->do_query(" alter table $name add timestamp "); +# Build the index. + $table->do_query(" sp_fulltext_table '$name', 'start_change_tracking' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + $table->do_query(" sp_fulltext_table '$name', 'start_background_updateindex' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + + return 1; +} + +sub post_create_table { +#-------------------------------------------------------------------------------- + shift->add_search_driver(@_); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Search.pm new file mode 100644 index 0000000..1c9ff62 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MSSQL/Search.pm @@ -0,0 +1,179 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.9 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MSSQL::Search; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 2, + }; + +sub load { + shift; + return GT::SQL::Search::MSSQL::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# overruns the usual query system with the mssql version +# + my $self = shift; + +# Find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# Add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# Parse query..., + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + $self->{'rejected_keywords'} = $rejected; + +# Setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + +# Now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $string = $self->_string ($buckets); + + return $self->sth({}) unless ($string =~ /\w/); + + my $table_name = $tbl->name(); + my ($pk) = $tbl->pk; + +# create the filter + my $filter_sql = $self->{filter} ? "WHERE ( " . $self->{filter}->sql . ' )' : ''; + +# If we have a callback, we need all results. + if ($self->{callback}) { + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my %results = $tbl->do_query($query)->fetchall_list; + my $results = $self->{callback}->($self, \%results); + $self->{rows} = $results ? scalar keys %$results : 0; + return $self->sth($results); + } + else { + my $mh = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + my $nh = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; +# First get the total. + $query = qq! + SELECT COUNT(*) + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my ($count) = $tbl->do_query($query)->fetchrow; + +# Now get results. + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + ORDER BY K.RANK DESC + !; + my %results = $tbl->do_query($query)->fetchall_list; + $self->{rows} = $count; + return $self->sth(\%results); + } +} + +sub _string { +# ------------------------------------------------------------------- +# Returns the string to use for containstable. +# + my ($self, $buckets) = @_; + +# union + my $tmp_bucket = $buckets->{keywords}; + my $union_request_str = join( + " or ", + map( + qq!"$_"!, + keys %{$buckets->{phrases}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# intersect + $tmp_bucket = $buckets->{keywords_must}; + my $intersect_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_must}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# disjoin + $tmp_bucket = $buckets->{keywords_cannot}; + my $disjoin_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_cannot}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# now build the query + my $tmp_request_str = join( + " and ", + ($union_request_str ? "( $union_request_str )" : ()), + ($intersect_request_str ? "( $intersect_request_str )" : ()), + ($disjoin_request_str ? "NOT ( $disjoin_request_str )" : ()) + ); + return $tmp_request_str; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Indexer.pm new file mode 100644 index 0000000..24e47c7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Indexer.pm @@ -0,0 +1,187 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Indexer +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.17 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Indexer; +# ------------------------------------------------------------------------------ +use strict; +use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; +use GT::SQL::Search::Base::Indexer; +@ISA = qw/GT::SQL::Search::Base::Indexer/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/; + +$ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MYSQLNONSUPPORT => 'Driver MYSQL requires MySQL version 3.23.23 or greater. Currently MySQL version: %s' +}; + +@$GT::SQL::ERRORS{ keys %$ERRORS } = values %$ERRORS; + +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +# ------------------------------------------------------------------------------ + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'MYSQL') { + return $class->error ('MYSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + my $sth = $tbl->do_query(qq!SELECT VERSION()!); + my $version = $sth->fetchrow; + my ($maj, $min) = split (/\./, $version); + unless ($maj > 3 or ($maj == 3 and $min >= 23)) { + return $class->error(MYSQLNONSUPPORT => WARN => $version); + } + return 1; +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return; + $tbl->connect(); + + my %weights = $tbl->weight() or return; + my $tblname = $tbl->name(); + +# Group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Drop unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# For each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + DROP INDEX $ft_name + !); + }; + +# Break on errors that can't be handled + if ( $@ ) { + next if $@ !~ /exist/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return $self->error(BADARGS => FATAL => "table must be passed into add_search_driver."); + my %weights = $tbl->weight() or return $self->error(NOWEIGHTS => 'WARN'); + my $tblname = $tbl->name() or return $self->error(BADARGS => FATAL => "table does not have a name?"); + +# group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Create unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# for each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $cols = join(",", sort @{$cols_grouped{$v}}); + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + ADD FULLTEXT $ft_name ( $cols ) + !); + }; + +# break on errors that can't be handled + if ( $@ ) { + next if $@ =~ /duplicate/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; + +} + +sub too_much { +# ------------------------------------------------------------------------------ +# returns true if there are too many records to be used on the Web +# + if ( $ENV{REQUEST_METHOD} ) { + my $self = shift; + my $tbl = $self->{table}; + if ( $tbl->count() > 5000 ) { + $self->error( 'NOTFROMWEB', 'WARN', $tbl->name() ); + return 1 + } + } + return; +} + +sub post_create_table { +# ------------------------------------------------------------------------------ + shift->add_search_driver(@_); +} + +sub reindex_all { +# ------------------------------------------------------------------------------ +# this will drop all the fulltext columns and reindex all of them. This should +# not be required unless the user changes the weights on one of their columns. +# Unfortunately, this method is not particularly smart and risks not dropping +# certain index columns and reindexes even when it's not required. It must be +# recoded at a future date, but as this action won't happen frequently and will +# rarely affect the user, it is not a priority. +# + my $self = shift; + + $self->drop_search_driver; + $self->add_search_driver; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Search.pm new file mode 100644 index 0000000..69165d7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/Search.pm @@ -0,0 +1,51 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.14 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Search; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub load { +# -------------------------------------------------- + my $self = shift; + my $opts = $self->common_param( @_ ); + +# determine which mysql search variant to use. + my $tbl = $opts->{table}; + my $ver_sth = $tbl->do_query( 'SELECT VERSION()' ); + my $version = $ver_sth->fetchrow_array(); + + my ( $maj, $min ) = split /\./, $version; + + my $pkg = 'GT::SQL::Search::MYSQL::'; + $pkg .= $maj > 3 ? 'VER4' : 'VER3'; + + eval "require $pkg"; + return $pkg->new(@_) +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER3.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER3.pm new file mode 100644 index 0000000..83c2638 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER3.pm @@ -0,0 +1,178 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER3 +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: VER3.pm,v 1.3 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER3; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub _phrase_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + + my $tmp = {}; + foreach my $keyword ( @{ $phrase->{phrase}|| [] } ) { + $tmp = $self->_get_words ( [ $keyword ], $tmp, 'intersect' ); + keys %$tmp or return {}; + } + foreach my $key ( keys %$tmp ) { $results->{$key} += $tmp->{$key} } + + } + + return $results; +} + +sub _get_phrase { +# ------------------------------------------------------------------------------ +# one day change this so it does words properly + return _get_words(@_); +} + +sub _union_query { +# ------------------------------------------------------------------------------ + return _get_words(@_); +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ + my ( $self, $keywords, $results ) = @_; + $keywords or return $results; + + foreach my $keyword ( keys %{ $keywords || {} } ) { + $results = $self->_get_words ( [ $keyword ], $results, 'intersect' ); + keys %$results or return {}; + } + + return $results; +} + +sub _phrase_intersect_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + if ( $tmp->{$key} ) { + $results->{$key} += $tmp->{$key}; + } + else { + delete $results->{$key} + } + } + + return $results; +} + +sub _disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return shift; + my $results = shift || {}; + + $results = $self->_get_words([ keys %{$words || {}} ], $results, 'disjoin' ); + + return $results; +} + +sub _phrase_disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return shift; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + $tmp->{$key} and delete $results->{$key}; + } +} + +sub _get_words { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return $_[0] || {}; + my $results = shift || {}; + my $mode = lc shift; + + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $tname = $tbl->name(); + my $wordlist = join " ", ( ref $words ? ( ref $words eq 'HASH' ? keys %$words : @$words ) : $words ) ; + my ($pk) = $tbl->pk; + + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + my $qwrds = quotemeta( $wordlist ); + my $where = ( $results and keys %$results ) + ? ("AND $pk IN(" . join(',', keys %$results) . ")") + : ''; + my $query = qq! + SELECT $pk, MATCH($cols) AGAINST ('$qwrds') AS SCORE + FROM $tname + WHERE MATCH($cols) AGAINST ('$qwrds') + $where + !; + my $sth = $tbl->do_query( $query ) or return; + + if ( $mode eq 'disjoin' ) { + while ( my $result = $sth->fetchrow ) { + delete $results->{$result}; + } + } + elsif ( $mode eq 'intersect' ) { + my $tmp = {}; + while ( my $aref = $sth->fetchrow_arrayref ) { + $tmp->{$aref->[0]} = $aref->[1]; + } + if ( $results and keys %$results ) { + while (my ($id, $score) = each %$results) { + if (not defined $tmp->{$id}) { + delete $results->{$id}; + next; + } + $results->{$id} += $score; + } + } + else { + $results = $tmp; + } + } + else { + while ( my $aref = $sth->fetchrow_arrayref ) { + $results->{$aref->[0]} += $aref->[1]; + } + } + return $results; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER4.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER4.pm new file mode 100644 index 0000000..43863b4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/MYSQL/VER4.pm @@ -0,0 +1,355 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER4 +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: VER4.pm,v 1.9 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER4; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $STOPWORDS = { map { $_ => 1 } qw/ + + a's able about above according accordingly across actually after + afterwards again against ain't all allow allows almost alone + along already also although always am among amongst an and another + any anybody anyhow anyone anything anyway anyways anywhere apart + appear appreciate appropriate are aren't around as aside ask asking + associated at available away awfully be became because become becomes + becoming been before beforehand behind being believe below beside + besides best better between beyond both brief but by c'mon c's came + can can't cannot cant cause causes certain certainly changes clearly + co com come comes concerning consequently consider considering + contain containing contains corresponding could couldn't course currently + definitely described despite did didn't different do does doesn't + doing don't done down downwards during each edu eg eight either else + elsewhere enough entirely especially et etc even ever every everybody + everyone everything everywhere ex exactly example except far few + fifth first five followed following follows for former formerly + forth four from further furthermore get gets getting given gives + go goes going gone got gotten greetings had hadn't happens hardly + has hasn't have haven't having he he's hello help hence her here + here's hereafter hereby herein hereupon hers herself hi him himself + his hither hopefully how howbeit however i'd i'll i'm i've ie if ignored + immediate in inasmuch inc indeed indicate indicated indicates inner + insofar instead into inward is isn't it it'd it'll it's its itself + just keep keeps kept know knows known last lately later latter latterly + least less lest let let's like liked likely little look looking looks + ltd mainly many may maybe me mean meanwhile merely might more + moreover most mostly much must my myself name namely nd near nearly + necessary need needs neither never nevertheless new next nine no + nobody non none noone nor normally not nothing novel now nowhere + obviously of off often oh ok okay old on once one ones only onto + or other others otherwise ought our ours ourselves out outside over + overall own particular particularly per perhaps placed please plus + possible presumably probably provides que quite qv rather rd re + really reasonably regarding regardless regards relatively respectively + right said same saw say saying says second secondly see seeing seem + seemed seeming seems seen self selves sensible sent serious seriously + seven several shall she should shouldn't since six so some somebody + somehow someone something sometime sometimes somewhat somewhere + soon sorry specified specify specifying still sub such sup sure + t's take taken tell tends th than thank thanks thanx that that's + thats the their theirs them themselves then thence there there's + thereafter thereby therefore therein theres thereupon these they + they'd they'll they're they've think third this thorough thoroughly + those though three through throughout thru thus to together too + took toward towards tried tries truly try trying twice two un + under unfortunately unless unlikely until unto up upon us use used + useful uses using usually value various very via viz vs want wants + was wasn't way we we'd we'll we're we've welcome well went were + weren't what what's whatever when whence whenever where where's + whereafter whereas whereby wherein whereupon wherever whether + which while whither who who's whoever whole whom whose why will + willing wish with within without won't wonder would would wouldn't + yes yet you you'd you'll you're you've your yours yourself + yourselves zero + + / }; + + $ATTRIBS = { + min_word_size => 4, + stopwords => $STOPWORDS, + }; + +sub query { +# -------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# create an easily accessible argument hash + my $args = $self->common_param(@_); + +# see if we can setup the filtering constraints + my $filter = { %$args }; + my $query = delete $args->{query} || $self->{query} || ''; + my $ftr_cond; + +# parse query + $self->debug( "Search Query: $query" ) if ($self->{_debug}); + my ( $query_struct, $rejected ) = $self->_parse_query_string( $query ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query_struct = $self->_preset_options( $query_struct, $args ); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + +# with the buckets, it's now possible to create a query string +# that can be passed directly into the FULLTEXT search. + my $query_string = ''; + + foreach my $search_type ( keys %$buckets ) { + my $bucket = $buckets->{$search_type}; + foreach my $token ( keys %$bucket ) { + next unless $token; + my $properties = $bucket->{$token} or next; + + my $e = ' '; + +# handle boolean operations + $properties->{mode} ||= ''; + if ( $properties->{mode} eq 'must' ) { + $e .= '+'; + } + elsif ( $properties->{mode} eq 'cannot' ) { + $e .= '-'; + } + +# deal with phrase vs keyword + if ( $properties->{phrase} ) { + $e .= '"' . quotemeta( $token ) . '"'; + } + else { + $e .= quotemeta $token; + +# substring match + $e .= '*' if $properties->{substring}; + } + + $query_string .= $e; + } + } + +# start building the GT::SQL::COndition object that will allow us to +# to retreive the data + + require GT::SQL::Condition; + my $tbl = $self->{table}; + my $constraints = GT::SQL::Condition->new; + +# create the GT::SQL::Condition object that will become the filtering +# constraints + my $filt = $self->{filter}; + + if ( $filt and ref $filt eq 'HASH' ) { + foreach my $fkey ( keys %$filt ) { + next if exists $args->{$fkey}; + $args->{$fkey} = $filt->{$fkey}; + } + } + + if ( my $filter_cond = $tbl->build_query_cond( $args ) ) { + $constraints->add( $filter_cond ); + } + +# if the cached filter object is a Condition object, append +# it to the filter set + if ( $filt and UNIVERSAL::isa( $filt, 'GT::SQL::Condition' ) ) { + $constraints->add( $filt ); + } + +# create our fulltext query condition + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + if ( $query_string ) { + $constraints->add( GT::SQL::Condition->new( + "MATCH( $cols )", + "AGAINST", + \"('$query_string' IN BOOLEAN MODE)" ) ); + } + +# calculate the cursor constraints + foreach my $k (qw( nh mh so sb )) { + next if defined $args->{$k}; + $args->{$k} = $self->{$k} || ''; + } + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25; + $args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score'; + +# if the sorting method is "score" the order is forced to "descend" (as there +# is almost no reason to order by worst matches) +# if the storing key is not "score", the default order will be "ascend" + $args->{so} = + $args->{sb} eq 'score' ? 'desc' : # comment out this entire line to prevent "descend" order forcing + ( (defined $args->{so} and $args->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : 'asc' ); + +# check that sb is not dangerous + my $sb = $self->clean_sb($args->{sb}, $args->{so}); + + $self->debug_dumper( "About to query. Constraint object: ", $constraints) if ($self->{_debug}); + +# Setup a limit only if there is no callback. The callback argument requires a full results list + unless ( $self->{callback} ) { + my $offset = ( $args->{nh} - 1 ) * $args->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $args->{mh}"); + } + + my $sth; + +# if the weights are all the same value, the query can be optimized +# to use just one MATCH AGAINST argument. However, if the weights +# are different, each element must be sectioned and queried separately +# with the weight value multipler + +# check to see if all the weight values are the same. + my $base_weight; + my $weights_same = 1; + foreach ( values %weights ) { + $base_weight ||= $_ or next; # init and skip 0s + next if $base_weight == $_; + $weights_same = 0; + last; + } + +# multiplex the action + my $result_cols = $self->{callback} ? ($tbl->pk)[0] : '*'; + + unless ( $query_string ) { + $sth = $tbl->select( [ $result_cols ], $constraints ) or return; + } + elsif ( $weights_same ) { + $sth = $tbl->select( [ $result_cols, "MATCH($cols) AGAINST ('$query_string' IN BOOLEAN MODE) AS score" ], $constraints ) + or return; + } + else { + +# group the multiplier counts + my %column_multiplier; + foreach ( keys %weights ) { + push @{$column_multiplier{$weights{$_}}}, $_; + } + + my @search_parameters; + foreach my $val ( keys %column_multiplier ) { + next unless $val; + + my $cols_ar = $column_multiplier{ $val } or next; + my $search_cols = join ",", @$cols_ar; + + if ( $val > 1 ) { + push @search_parameters, "( ( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) ) * $val )"; + } + else { + push @search_parameters, "( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) )"; + } + } + + my $search_sql = "( " . join( " + ", @search_parameters ) . " ) AS score"; + + $sth = $tbl->select( [ $result_cols, $search_sql ], $constraints ) + or return; + } + +# If we have a callback, we fetch the primary key => score and pass that hash into +# the filter. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + my %results = map { $_->[0] => $_->[1] } @{$sth->fetchall_arrayref}; + + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %results) . " results.", \%results) if ($self->{_debug}); + my $filtered = $self->{callback}->($self, \%results) || {}; + $self->debug_dumper("New result set: " . scalar (keys %$filtered) . " results.", $filtered) if ($self->{_debug}); + + $self->{rows} = scalar keys %$filtered; + return $self->sth($filtered); + } + +# count the number of hits. create a query for this purpose only if we are required to. + $self->{rows} = $sth->rows(); + if (($args->{nh} > 1) or ($self->{rows} == $args->{mh})) { + $self->{rows} = $tbl->count($constraints); + } + return $sth; +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Indexer.pm new file mode 100644 index 0000000..bddcc9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Indexer.pm @@ -0,0 +1,25 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::NONINDEXED::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $DEBUG/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Indexer->new(@_) +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Search.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Search.pm new file mode 100644 index 0000000..94b6334 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/NONINDEXED/Search.pm @@ -0,0 +1,257 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Search +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.30 2006/08/09 06:58:39 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Nonindex search system +# + +package GT::SQL::Search::NONINDEXED::Search; +# ================================================================== + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG/; + use GT::SQL::Search::Base::Search; + use GT::SQL::Condition; + @ISA = qw( GT::SQL::Search::Base::Search ); + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# parse based on latin characters + latin_query_parse => 0 + }; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + + require GT::SQL::Condition; + my $query_condition = new GT::SQL::Condition; + +# now handle the separate possibilities +# the union + my $union_cond = $self->_get_condition( $buckets->{keywords}, $buckets->{phrases} ); + $query_condition->add(GT::SQL::Condition->new(@$union_cond, 'OR')) if $union_cond; +# the intersect + my $intersect_cond = $self->_get_condition( $buckets->{keywords_must}, $buckets->{phrases_must} ); + $query_condition->add(GT::SQL::Condition->new(@$intersect_cond)) if $intersect_cond; + +# the disjoin + my $disjoin_cond = $self->_get_condition( $buckets->{keywords_cannot}, $buckets->{phrases_cannot} ); + $query_condition->add(GT::SQL::Condition->new(@$disjoin_cond, 'OR')->not) if $disjoin_cond; + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $column = $_) =~ s/-[lg]t$//; + exists $cols->{$column} + ? ($_ => $input->{$_}) + : () + } keys %{$input}; + +# if there was no query nor filter return nothing. + keys %$query or keys %filters or return $self->sth({}); + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $self->_add_filters( \%filters ); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + elsif ($self->{filter} and keys %{$self->{filter}} ) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll do that here + $self->{filter} = undef; + + my $tbl = $self->{table}; + my ($pk) = $tbl->pk; + +# now run through a callback function if needed. + if ($self->{callback}) { + +# Warning: this slows things a heck of a lot. + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + + my $sth = $tbl->select( [ $pk ], $query_condition ); + my $results = {}; + while (my $result = $sth->fetchrow) { + $results->{$result} = undef; + } + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $self->{rows} = scalar($results ? keys %{$results} : ()); + + return $self->sth( $results ); + } + +# and now create a search sth object to handle all this + $input->{nh} = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + $input->{mh} = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; + $input->{so} = (defined $input->{so} and $input->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : ''; + +# check that sb is not dangerous + my $sb = $self->clean_sb($input->{sb}, $input->{so}); + + my $offset = ( $input->{nh} - 1 ) * $input->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $input->{mh}"); + my $sth = $tbl->select( $query_condition ) or return; + +# so how many hits did we get? + $self->{rows} = $sth->rows(); + if (($input->{nh} > 1) or ($self->{rows} == $input->{mh})) { + $self->{rows} = $tbl->count($query_condition); + } + return $sth; +} + +sub _get_condition { +#------------------------------------------------------------------------------- + my ( $self, $keywords, $phrases ) = @_; + + my @list = ( keys %$keywords, keys %$phrases ); + + my $tbl = $self->{table} or return $self->error( 'NODRIVER', 'FATAL' ); + my @cond = (); + my %tmp = $tbl->weight(); + my @weights = keys %tmp or return; + foreach my $element ( @list ) { + my @where = (); + foreach my $cols ( @weights ) { + push @where, [$cols, 'LIKE', "%$element%"]; # Condition does quoting by default. + } + push @cond, GT::SQL::Condition->new(@where, 'OR'); + } + @cond or return; + + return \@cond; +} + +sub _parse_query_string { +#------------------------------------------------------------ +# Parses a query string '+foo -"bar this" alpha' into a hash of +# words and modes. +# + my ($self, $text) = @_; + my %modes = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# Latin will break up on actual words and punctuation. + if ($self->{latin_query_parse}) { + return $self->SUPER::_parse_query_string( $text ); + } + else { + my $words = {}; + my @terms; + my $i = 0; + foreach my $term (split /"/, $text) { + push @terms, ($i++ % 2 ? $term : split ' ', $term); + } + for (my $i = 0; $i < @terms; $i++) { + my $word = $terms[$i]; + $word =~ s/^\s*|\s*$//g; + next if ($word eq ''); + if ($i < $#terms) { + ($word eq '-') and ($word = '-' . $terms[++$i]); + ($word eq '+') and ($word = '+' . $terms[++$i]); + } + $word =~ s/^([<>+-])//; + my $mode = ($1 and $modes{$1} or 'can'); + my $substring = ($word =~ s/\*$//) || 0; + if ($word =~ /\s/) { + $words->{$word} = { + mode => $mode, + phrase => 1, + substring => $substring, + keyword => 0, + }; + } + elsif ($word) { + $words->{$word} = { + mode => $mode, + phrase => 0, + substring => $substring, + keyword => 1, + }; + } + } + return $words; + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Table.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Table.pm new file mode 100644 index 0000000..15ad4b9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Table.pm @@ -0,0 +1,3006 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# CVS Info : 087,071,086,086,085 +# $Id: Table.pm,v 1.274 2008/09/17 19:35:24 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to store and retrieve data from a table. +# + +package GT::SQL::Table; +# =============================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::Config; +use GT::AutoLoader(NAME => '_AUTOLOAD'); +use strict; +use vars qw/$DEBUG $VERSION @ISA $AUTOLOAD $ERROR_MESSAGE @COL_ATTRIBS/; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.274 $ =~ /(\d+)\.(\d+)/; +@COL_ATTRIBS = qw/size type values default not_null pos regex weight form_display form_size form_type form_names form_values time_check/; +$ERROR_MESSAGE = 'GT::SQL'; + +use constants DEF_HEADER => <<'HEADER'; +# Database definition file for '%TABLE_NAME%' table +# Last updated: [localtime] +# Created by GT::SQL::Table $Revision: 1.274 $ +HEADER + +sub new { +# ----------------------------------------------------------------------------- +# GT::SQL::Table->new( +# name => table_name, +# debug => debug level, +# _err_pkg => package name, +# driver => driver name, +# ); +# ----------------------------------------------------------------------------- +# Constructs (or returns if it already exists) a new GT::SQL::Object with the +# parameters specified above. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->new(HASH or HASH_REF or CGI) only'); + + $self->{connect} = $opts->{connect} || {}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{_index} = 0; + $self->{_file} = 0; + +# Must have {connect} info first. + $self->name($opts->{name}); + $self->{name} ||= ''; + if (-f "$self->{connect}->{def_path}/$self->{name}.def" and not $opts->{_schema}) { + $self->load_state; + } + elsif ($opts->{_schema} and UNIVERSAL::isa($opts->{_schema}, 'GT::Config')) { + # If _schema is passed as a GT::Config object, use it directory. This + # is primarily used for subclassed tables - see GT::SQL::Base::new_table() + $self->{schema} = $opts->{_schema}; + } + else { + $self->{schema} = { %{$opts->{_schema}} } if $opts->{_schema}; + $self->_new_schema if length $self->{name}; + } + +# Some defaults for writing to + $self->{schema}->{index} ||= {}; + $self->{schema}->{unique} ||= {}; + $self->{schema}->{cols} ||= {}; + $self->{schema}->{pk} ||= []; + $self->{schema}->{fk} ||= {}; + $self->{schema}->{subclass} ||= {}; + $self->{schema}->{ai} ||= ''; + $self->{schema}->{fk_tables} ||= []; + + { # Check for weights or file columns and set _file and _index accordingly + my ($found_file, $found_weight); + my $c = $self->{schema}->{cols}; + for (keys %$c) { + if (!$found_file and $c->{$_}->{form_type} and uc $c->{$_}->{form_type} eq 'FILE') { + $self->_file_cols(); + $self->{_file} = ++$found_file; + } + if (!$found_weight and $c->{$_}->{weight}) { + $self->{_index} = ++$found_weight; + } + last if $found_file and $found_weight; + } + } + + $self->debug("Table '$self->{name}' object created.") if ($self->{_debug} > 2); + return $self; +} + +sub DESTROY {} + +sub AUTOLOAD { +# ------------------------------------------------------------- +# This method provides get methods for all the cols attributes. +# It returns a hash reference of the column names to the value +# of the attribute for that attribute. +# + my $self = $_[0]; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + +# Otherwise we have auto generated functions for each of the +# column names. + if (grep { $what eq $_ } @COL_ATTRIBS) { + no strict 'refs'; + *$AUTOLOAD = sub { + my $self = shift; + my $h = {}; + for my $col (keys %{$self->{schema}->{cols}}) { + if (exists $self->{schema}->{cols}->{$col}->{$what}) { + $h->{$col} = $self->{schema}->{cols}->{$col}->{$what}; + } + } + wantarray ? %$h : $h; + }; + goto &$AUTOLOAD; + } + +# Pass to the imported &_AUTOLOAD, which handles loading from %COMPILE + goto &_AUTOLOAD; +} + +# Loads a new ->{schema} GT::Config object that, when saved, will create the +# def file. The config object created is always empty, but any existing values +# in ->{schema} will be copied into the object. Thus, saving will always +# overwrite anything stored in this table's def file. +$COMPILE{_new_schema} = __LINE__ . <<'END_OF_SUB'; +sub _new_schema { + my $self = shift; + my $name = $self->name; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + my %old = $self->{schema} ? %{$self->{schema}} : (); + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + local => 0, + empty => 1, + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + %{$self->{schema}} = %old; + $self->{schema}; +} +END_OF_SUB + +sub load_state { +# ----------------------------------------------------------------------------- +# $obj->load_state; +# ----------------- +# Loads relation structure from def file. If you want to reload the +# structure currently stored on disk, you should call ->reload or ->reset - +# this method caches files (via GT::Config). +# + my ($self, $reload) = @_; + my $name = $self->name; + -e "$self->{connect}->{def_path}/$name.def" or return $self->fatal(FILENOEXISTS => "$self->{connect}->{def_path}/$name.def"); + $self->debug("Loading state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + cache => !($reload and $reload eq 'reload'), + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + $self->{driver}->{schema} = $self->{schema} if $self->{driver} and exists $self->{driver}->{schema}; + $self->debug("State loaded for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + return 1; +} + +$COMPILE{reload} = __LINE__ . <<'END_OF_SUB'; +sub reload { +# ----------------------------------------------------------------------------- +# $obj->reload; +# ------------- + shift->load_state('reload'); +} +END_OF_SUB + +sub reset { +# ----------------------------------------------------------------------------- +# Works just like reload, except it always returns false, allowing for a +# shortcut such as: +# +# $code->that_changes($table) or return $table->reset; +# + shift->load_state('reload'); + return; +} + +# -------------------------------------------------------------------------------------- # +# SQL OPERATIONS # +# -------------------------------------------------------------------------------------- # + +sub add { +# ----------------------------------------------------------- +# add() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to add. +# OUT: ID number if auto_incremented table, or undef if failure +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->add(HASH or HASH_REF or CGI) only.'); + $input = {%$input}; + my $table = $self->name or return $self->fatal('NOTABLE'); + + my $c = $self->{schema}->{cols}; + my $ai = $self->{schema}->{ai}; + my $err = 0; + + my %skip_check = ( + $ai => 1 + ); + + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + $skip_check{$tree->father_id_col}++; + $skip_check{$tree->root_id_col}++; + $skip_check{$tree->depth_col}++; + } + +# Clear errors. + $self->{_error} = []; + + for my $col (keys %$c) { + my $default = $c->{$col}->{default}; + next if $skip_check{$col}; + my $set = defined $input->{$col} && $input->{$col} =~ /\S/; + +# The following code is a little inconsistent (not_null sometimes means a value +# is required, sometimes it doesn't) because it needs to be backwards +# compatible. Changing this behaviour will break a lot of code. + unless ($set) { + if ($c->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL)$/) { +# If we have a default, use it, otherwise set it to undef so that it will get +# inserted as NULL or return a NOTNULL error (see _check_value()). + if (defined $default and length $default) { + delete $input->{$col}; + } + else { + $input->{$col} = undef; + } + } + elsif ($c->{$col}->{type} =~ /^(?:CHAR|VARCHAR|.*TEXT)$/) { +# The only cases where the default is used is when we have a default and it +# hasn't been passed into add(). Otherwise, set the column to undef (to catch +# NOTNULL) or an empty string, depending on the not_null setting of the column. + if (!exists $input->{$col} and defined $default and length $default) { + delete $input->{$col}; + } + else { + $input->{$col} = $c->{$col}->{not_null} ? undef : ''; + } + } +# For all other column types just do what <=r1.256 did, except set the value to +# undef so _check_value() catches the NOTNULL instead of triggering it here so +# we don't get duplicate errors. + elsif ($c->{$col}->{not_null} and not (!exists $input->{$col} and defined $default and length $default)) { + $input->{$col} = undef; + } + } + } + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + my $sth = $self->insert($input); + return $sth ? $ai ? $sth->insert_id : 1 : undef; +} + +sub insert { +# ----------------------------------------------------------- +# $obj->insert(key1 => $value1, key2 => $value2); +# ------------------------------------------------ +# Key values pairs that correspond to the row you are +# inserting. +# +# $obj->insert(\%row); +# --------------------- +# A hash that contains key value pairs that corespond to +# the row you are inserting. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF) only.'); + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data. + keys %$opts or return $self->warn(NOVALUES => "insert()"); + +# Copy the data and remove anything that doesn't make sense here. + my $c = $self->{schema}->{cols}; + my %set = map { exists $opts->{$_} ? ($_ => $opts->{$_}) : () } keys %$c; + +# Check for file uploads. + my ($fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) { + require GT::SQL::File; + $fset = GT::SQL::File->pre_file_actions(\%fcols, \%set, $opts) or return; + } + + my $tree; + if ($self->{schema}->{tree}) { + $tree = $self->tree; + my $f = $tree->father_id_col; + my $r = $tree->root_id_col; + my $d = $tree->depth_col; + if ($set{$f}) { + my $pk = $self->{schema}->{pk}->[0]; + my ($root, $depth) = $self->select($r, $d, { $pk => $set{$f} })->fetchrow; + $set{$r} = $root || $set{$f}; + $set{$d} = $depth + 1; + } + else { + $set{$f} = $set{$r} = $set{$d} = 0; # A root record + } + } + + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_insert(\%set) or return; + } + $self->{last_insert} = \%set; + +# Weighted indexing needs special handling + my $tmp_weight; + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $tmp_weight = $self->_get_indexer->pre_add_record( $self->{last_insert} ) or return; + } + + my $sth = $self->{driver}->insert(\%set) or return; + +# If we have files, let's save them. + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + if ((my @pk = $self->pk()) == 1 and keys %fcols) { + my $key = $self->ai() ? $sth->insert_id : $set{$pk[0]}; + require GT::SQL::File; + my $tbl = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }) or return; + $tbl->add_file({ %set, %$fset }, $key) or return; + } + } + +# Finish off special handling for weighted indexing + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $self->_get_indexer->post_add_record( $self->{last_insert}, $sth, $tmp_weight ) or return; + } + +# If a tree exists, insert any new entries required + if ($self->{schema}->{tree}) { + $tree->insert(insert_id => $sth->insert_id, data => \%set); + } + + return $sth; +} + +$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB'; +sub insert_multiple { +# ----------------------------------------------------------- +# $obj->insert_multiple(['key1', 'key2', 'key3'], [$value1_1, $value1_2, $value1_3], [$value2_1, $value2_2, $value2_3], ...); +# ------------------------------------------------ +# The first array ref is the columns, and all following array refs are the +# values to be inserted. +# +# This method doesn't mess around - it doesn't check to make sure all the +# columns you entered exist, nor does it do foreign key checks, nor does it +# handle raw SQL values via scalar references (it does, however, support +# undef as NULL). Currently, it does not support file columns or columns +# indexed by GT::SQL's 'INTERNAL' indexer. +# +# Returned is the number of _queries_ successfully executed, or undef if no +# queries were executed successfully. Note that the number of queries is not +# necessarily the same as the number of rows insert - in particular, several +# rows may be inserted in a single query in some databases (currently, +# MySQL). +# + my ($self, $cols, @values) = @_; + $cols or return $self->fatal(BADARGS => 'Usage: $obj->insert_multiple(ARRAY_REF, ARRAY_REF, ...) only'); + + my $table = $self->name or return $self->fatal('NOTABLE'); + + $self->{schema}->{tree} and return $self->fatal(TREENOCANDO => 'insert_multiple', $table); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data, and the right number for each insert. + @values or return $self->warn(NOVALUES => "insert()"); + for my $val (@values) { + if (@$val != @$cols) { + return $self->fatal(BADMULTVALUES => 'insert_multiple()'); + } + } + + my $c = $self->{schema}->{cols}; + for (my $i = 0; $i < @$cols; $i++) { + unless (exists $c->{$cols->[$i]}) { + splice @$cols, $i, 1; + for my $val (@values) { + splice @$val, $i, 1; + } + --$i; + } + } + +# Query is executed inside to handle ai fields. + $self->{driver}->insert_multiple($cols, \@values) or return; +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->modify(HASH or HASH_REF or CGI) only.'); + $input = {%$input}; + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + + my $err; + +# Remove primary keys from update clause and make sure we have a primary key. + my $where; + for my $key (@{$self->{schema}->{pk}}) { + $where->{$key} = delete $input->{$key} if exists $input->{$key}; + } + unless (keys %{$where} == @{$self->{schema}->{pk}}) { + $self->warn('NOPKTOMOD'); + $err++; + } + +# Check to see if the record has been updated since the original record was retrieved. + $err++ unless $self->_check_timestamp($where, $input); + +# If we caught any errors, return. + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + + my $cols = $self->{schema}->{cols}; + for my $col (keys %$cols) { + +# update() will handle not null checks + next unless exists $input->{$col}; + +# Don't allow modification of timestamps + if ($cols->{$col}->{type} eq 'TIMESTAMP') { + delete $input->{$col}; + } +# Treat numeric and date columns set to empty strings as NULL (the update() +# will catch NOT NULL errors). Do this with date columns because '' is not a +# valid date. + elsif ($cols->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL|DATE|TIME|DATETIME)$/ and defined $input->{$col} and $input->{$col} eq '') { + $input->{$col} = undef; + } +# For add and modify, empty strings are considered as NULL, so set these values +# to undef so it triggers a NOT NULL error during the update(). + elsif ($cols->{$col}->{not_null} and not (defined $input->{$col} and length $input->{$col})) { + $input->{$col} = undef; + } + } + +# Execute the update + $self->update($input, $where) or return; + return 1; +} +END_OF_SUB + +sub update { +# ----------------------------------------------------------- +# $obj->update($hash_ref, $condition, $opts); +# ------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->update($hash_ref_1, $hash_ref_2, $opts); +# ---------------------------------------- +# Hash1 is what needs to be changed. +# Hash2 is the condition. +# + my $self = shift; + my ($set, $where, $opts) = @_; + ref $set eq 'HASH' or return $self->fatal(BADARGS => 'Usage: $obj->update(HASH_REF, CONDITION_OBJ or HASH_REF, HASH_REF)'); + keys %$set or return $self->fatal(BADARGS => 'update called with nothing to set!'); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Check to make sure the update is possible + $opts ||= {}; + $where ||= {}; # Update all. + + my $where_cond = $self->_build_cond($where); + +# Check to see if we have files to update. + my ($fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) { + my @pk = $self->pk(); + if (@pk == 1) { + my @ids = $self->select($pk[0], $where_cond)->fetchall_list(); + + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $fset = $file->pre_file_actions(\%fcols, $set, $opts, \@ids) or return; + + if (not keys %$set and not keys %$fset) { + return $self->warn(BADARGS => "update called with nothing to set!"); + } + } + else { + for my $col (keys %fcols) { + delete $set->{$col}; + delete $set->{"${col}_del"}; + delete $set->{"${col}_filename"}; + } + } + } + +# If there is a tree, and the father_id is being updated, call the appropriate tree method. + my $tree_data; + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + if (exists $set->{$tree->father_id_col}) { + $tree_data = $tree->pre_update(where => $where_cond, data => $set) or return; + } + } + +# Remove any invalid columns from the set (_build_set also does this, but +# _check_update uses $set) + for my $key (keys %$set) { + delete $set->{$key} unless exists $self->{schema}->{cols}->{$key}; + } + +# Validate data. + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_update($set, $where) or return; + } + my $set_cond = $self->_build_set($set); + +# If we are updating this tables primary key, then get the original +# value and save it for after the update. + my $pk = $self->{schema}->{pk}; + my $where_r = $where_cond->as_hash; + my @update_pk; + for (@$pk) { + if (defined $set->{$_} and defined $where_r->{$_} and $set->{$_} ne $where_r->{$_}) { + push @update_pk, $_; + } + } + +# Update the search index if changing a weighted column. + my $tmp_weights = {}; + my %wcols; + if ($self->{_index} and ! $opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $tmp_weights = $self->_get_indexer->pre_update_record( $set_cond, $where_cond ) or return; + last; + } + } + } + + $self->{sel_opts} ||= []; + +# Save the where clause. + $self->{last_where} = $where_cond; + +# Perform the update. + my $sth = $self->{driver}->update($set_cond, $where_cond) or return; + +# The query was successful, so now if there is a tree, call the tree's update method + if ($tree_data) { + $self->tree->update($tree_data); + } + +# Update the foreign keys of other tables if this tables primary key changed. + for my $key (@update_pk) { + for my $table (@{$self->{schema}->{fk_tables}}) { + my $new_me = $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + my $fk_hash = $new_me->{schema}->{fk}->{$self->name} or next; + for my $my_col (keys %$fk_hash) { + if ($fk_hash->{$my_col} eq $key) { + $new_me->update({ $my_col => $set->{$key} }, { $my_col => $where_r->{$key} }); + } + } + } + } + +# Update any file changes. + if (keys %fcols and $self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $File->update_records({ %$set, %$fset }, $where_cond) or return; + } + +# Update the search index if required. + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $self->_get_indexer->post_update_record( $set_cond, $where_cond, $tmp_weights ) or return; + last; + } + } + } + return $sth; +} + +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition); +# -------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->delete($val); +# ---------------------- +# Deletes a single record based on the scalar value being the +# primary key. +# +# $obj->delete([$val1, $val2]); +# -------------------------------- +# If you have a composite primary key, deletes a single record +# based on the values being the primary keys. +# +# NOTE: use delete_all to delete everything +# + my $self = shift; + @_ > 0 or return $self->fatal(BADARGS => "You must call delete_all to delete all entries"); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; +# Clear errors. + $self->{_error} = []; + + my ($opt, $cond, $where, $do_select, %del, @rows); + +# Determine what sort of delete to do. + unless (@_ == 1) { + for my $i (0 .. $#_) { + $_ = $_[$i]; + /^abort$/ and do { $opt = splice(@_, $i, 1); last }; + /^cascade$/ and do { $opt = splice(@_, $i, 1); last }; + /^ignore$/ and do { $opt = splice(@_, $i, 1); last }; + /^cleanup$/ and do { $opt = splice(@_, $i, 1); last }; + } + } + +# Get the where clause we are going to use to do the delete. This can be +# either from a a scalar/array reference representing the primary key, or a +# condition/hash reference representing a where clause. + if ( ((ref $_[0] eq 'ARRAY') or (not ref $_[0])) and (@_ == 1) ) { + my @keys = @{$self->{schema}->{pk}}; + my @vals = ref $_[0] ? @{shift()} : shift(); + my $href = {}; + if (@keys != @vals) { + return $self->fatal(BADARGS => "Your primary key is made of " . @keys . " elements, but you passed in " . @vals . " elements."); + } + while (@vals) { + $href->{shift(@keys)} = shift(@vals); + } + (keys %{$href}) or return $self->fatal(BADARGS => 'Usage: $obj->delete(CONDITION_OBJ or PRIMARY_KEY or [PRIMARY_KEY1, PRIMARY_KEY2])'); + $where = $self->_build_cond($href); + } + else { + ($where, $do_select) = _extract_where(@_); + } + +# Make sure $where is not empty. + if (! $where->sql) { + return $self->fatal(BADARGS => "Could not create a condition object out of arguments."); + } + +# Save the where clause. + $self->{last_where} = $where; + $opt ||= 'cascade'; + +# Do a 'cascade' or 'abort' delete. + if ($opt ne 'ignore' and $opt ne 'cleanup' and @{$self->fk_tables}) { + my $sth; +# If they passed in a complex condition we select + if ($do_select) { + $sth = $self->select($where); + } +# If the hash that was passed in does not contain the foreign keys we select + elsif (not $self->_check_keys($where)) { + $sth = $self->select($where); + } + + if ($sth) { + $self->_delete_select($sth, $opt) or return + } + else { + $self->_delete_cond($where, $opt) or return + } + } + +# now handle the indexes if that's required + my $tmp_weights = {}; + if ($self->{_index} and $self->_weight_cols) { + $tmp_weights = $self->_get_indexer()->pre_delete_record( $where ) or return; + } + +# delete anything related to tables + if ($self->{_file} and $self->_file_cols() ) { + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $file->delete_records( $where ); + } + +# For many to one fk relations + my $rows; + if ($opt eq 'cleanup') { + defined($rows = $self->_delete_cleanup($where)) or return; + } + else { +# Get the SQL. + my $sth = $self->{driver}->delete($where) or return; + $rows = $sth->rows; + } + + if ($self->{_index} and $self->_weight_cols) { + $self->_get_indexer()->post_delete_record( $where, $tmp_weights ) or return; + } + + defined $rows or return; + return ($rows == 0) ? "0E0" : $rows; +} + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# $obj->delete_all; +# ----------------- +# Deletes all the records in the current table. +# + my ($self, $opt, $done) = @_; # $done is used internally + $opt ||= 'cascade'; + my $name = $self->name or return $self->fatal('NOTABLE'); + $done ||= { $name => 1 }; + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Do the cascading delete. + for my $fktable (@{$self->fk_tables}) { + next if $done->{$fktable}++; + my $new_me = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + if ($opt eq 'cascade') { + $done->{$fktable}++; + $new_me->delete_all($opt, $done) or return; + } + else { + $new_me->count and return $self->warn(DEPENDENCY => $fktable); + } + } + my $tmp_weights = {}; + if ($self->_weight_cols()) { $tmp_weights = $self->_get_indexer()->pre_delete_all_records() or return } + my $sth = $self->{driver}->delete() or return; + if ($self->_weight_cols()) { $self->_get_indexer()->post_delete_all_records($tmp_weights) or return } + + $sth; +} +END_OF_SUB + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ------------------------------------------------------------------- +# Just performs the query and returns a fetchall. +# + return shift->_query(@_)->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ------------------------------------------------------------------- +# Just performs the query and returns an active sth. +# + return shift->_query(@_); +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ------------------------------------------------------------------- +# Parses the input, and runs a select based on input. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF or CGI) only.'); + $self->name or return $self->fatal('NOTABLE'); +# Clear errors. + $self->{_error} = []; + +# Strip out values that are empty or blank (as query is generally derived from +# cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts; + $opts = \%input; + +# If build_query_cond returns a GT::SQL::Search object, then we are done. + my $cond = $self->build_query_cond($opts, $self->{schema}->{cols}); + + if ( ( ref $cond ) =~ /(?:DBI::st|::STH)$/i ) { + return $cond; + } + +# If we have a callback, then we get all the results as a hash, send them +# to the callback, and then do the regular query on the remaining set. + if (defined $opts->{callback} and (ref $opts->{callback} eq 'CODE')) { + my $pk = $self->{schema}->{pk}->[0]; + my $sth = $self->select($pk, $cond) or return; + my %res = map { $_ => 1 } $sth->fetchall_list; + my $new_results = $opts->{callback}->($self, \%res); + $cond = GT::SQL::Condition->new($pk, 'IN', [keys %$new_results]); + } + +# Set the limit clause, defaults to 25, set to -1 for none. + my $in = $self->_get_search_opts($opts); + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1; + +# Now do the select. + my @sel = (); + if ($cond) { push @sel, $cond } + if ($opts->{rs} and $cond) { push @sel, $opts->{rs} } + my $sth = $self->select(@sel) or return; + + return $sth; +} +END_OF_SUB + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want append to your search. +# Select options will be used for delete, and select. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_; + wantarray ? @{$self->{sel_opts}} : $self->{sel_opts}; +} + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that you wish returned. If none are +# specified all fields will be returned. +# + my $self = shift; + my $sel_opts = $self->{sel_opts} || []; + $self->{sel_opts} = []; + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Get the list of select fields. + my (@fields); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_} } + elsif (not ref $_) { push @fields, $_ } + } + @fields = grep defined && length, @fields; +# Extract the where clause and save it for future. + my ($where, $do_select) = _extract_where(@_); + $self->{last_where} = $where; + +# Perform the select + my $sth = $self->{driver}->select(\@fields, $where, $sel_opts) or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it. + $sel_opts = join " ", @$sel_opts; + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined $3) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif (defined $4) { # Pg-style with OFFSET before LIMIT + ($offset, $limit) = ($4, $5); + } + else { + ($limit, $offset) = ($1, $2 || 0); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + return $sth; +} + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# get() +# IN : primary key and format options, and fields wanted. +# OUT: array_ref/hash_ref on success, undef on failure. +# + my $self = shift; + +# Connect to the database if we are not already connected + $self->connect or return; + + my (@keys, @pk, @sel, $cond, $method, $format, $cols); + $self->name or return $self->fatal('NOTABLE'); + $cond = GT::SQL::Condition->new; + + if (@_ == 0) { return $self->fatal(BADARGS => 'Usage: $obj->get(HASH or HASH_REF or CGI_OBJ)') } + elsif (ref $_[0] eq 'HASH') { + my $href = shift; + for (keys %{$href}) { + $cond->add($_, '=', $href->{$_}); + } + } + else { + @keys = ref $_[0] eq 'ARRAY' ? @{shift()} : (shift); + @pk = @{$self->{schema}->{pk}}; + while (@keys) { + $cond->add(shift(@pk), '=', shift(@keys)); + } + } + + $format = uc shift || 'HASH'; + $cols = shift || []; + $method = $format eq 'ARRAY' ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond, $cols); + if ($sth) { + return $sth->$method(); + } + else { + return; + } +} +END_OF_SUB + +sub do_query { +# ----------------------------------------------------------- +# $obj->do_query($query) +# $obj->do_query($query, \@args); +# ------------------------ +# Performs SQL $query and returns a +# Query object as the result of this query. +# + my ($self, $query, $args) = @_; + + $self->connect or return; + $query = $self unless (ref $self || $query); + +# Show the query if debug is on. + $self->debug("Query: $query\n") if $self->{_debug} > 1; + +# Do the query. + my $sth = $self->{driver}->prepare($query) or return; + if ($args and ref $args eq 'ARRAY') { + $sth->execute(@$args) or return; + } + else { + $sth->execute or return; + } + $self->{sel_opts} = []; + return $sth; +} + +$COMPILE{do} = __LINE__ . <<'END_OF_SUB'; +sub do { + my $self = shift; + return $self->do_query(@_); +} +END_OF_SUB + +$COMPILE{reindex} = __LINE__ . <<'END_OF_SUB'; +sub reindex { +# ----------------------------------------------------------- +# $obj->reindex() +# ----------------------------------- +# Reindexes the database if required +# + my $self = shift; + my $opts = shift; + + $self->connect or return; + my $Indexer = $self->_get_indexer(); + $Indexer->reindex_all( $self, $opts ); +} +END_OF_SUB + +$COMPILE{indexing} = __LINE__ . <<'END_OF_SUB'; +sub indexing { +# ----------------------------------------------------------- +# $obj->indexing(0/1); +# -------------------- +# Enables/Disables indexing, spans life of object. +# + @_ == 2 and ($_[0]->{_index} = $_[1]); + return $_[0]->{_index}; +} +END_OF_SUB + +$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB'; +sub prepare { +# ----------------------------------------------------------- +# Passes query straight through to dbh. +# + my ($self, $query) = @_; + $self->connect or return; + return $self->{driver}->prepare($query); +} +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns the name of the current table instance. +# +# $obj->name($table_name); +# ------------------------- +# Sets the name for the table to create. +# + my $self = shift; + if (defined $_[0]) { + my $name = shift; + my $prefix = $self->{connect}->{PREFIX}; + if (length $prefix) { + unless ($name =~ /^$prefix/) { + $name = $prefix . $name; + } + } + unless ($name =~ /^(\w+)$/) { + return $self->fatal(BADNAME => $name); + } + $self->{name} = $1; + + # If a schema exists, a new GT::Config object is needed as the name just changed + $self->_new_schema if $self->{schema}; + } + return $self->{name}; +} + +# -------------------------------------------------------------------------------------- # +# ACCESSOR METHODS # +# -------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the hash structure for this tables +# cols. +# +# $obj->cols($hash_ref); +# ---------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols($array_ref); +# ----------------------- +# Just like $hash_ref, except an array ref. The array should look like: +# [ $col_name => { type => 'int' } ]. The difference between this and +# using a hash reference is that with the array ref pos will be automatically +# calculated and set in each column definition. The following two lines passed +# to cols() are equivelant and internally become the same thing: +# +# { $col1 => { type => 'int', pos => 1 }, $col2 => { type => 'text', pos => 2 } } +# [ $col1 => { type => 'int' }, $col2 => { type => 'text' } ] +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# ---------------------- +# Sets the relations columns as specified via method +# params. +# + my $self = shift; + + if (@_) { + if (@_== 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{cols} = $arg; + } + elsif (ref $arg eq 'ARRAY' and not @$arg % 2) { + for (0 .. 0.5 * @$arg - 1) { + $arg->[2 * $_ + 1]->{pos} = $_ + 1; + } + $self->{schema}->{cols} = {@$arg}; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->cols(HASH_REF or ARRAY_REF or HASH)'); + } + } + elsif (not @_ % 2) { $self->{schema}->{cols} = {@_} } + else { return $self->fatal(BADARGS => 'Usage $obj->cols(HASH_REF or ARRAY_REF or HASH)') } + + my $name = $self->{name}; + for (keys %{$self->{schema}->{cols}}) { + ref $self->{schema}->{cols}->{$_} eq 'HASH' or return $self->fatal(BADARGS => 'You must have a hash of hashes to specify your columns'); + exists $self->{schema}->{cols}->{$_}->{type} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no type defined."); + exists $self->{schema}->{cols}->{$_}->{pos} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no position defined."); + } + } + + return $self->{schema}->{cols} unless wantarray; + +# Wantarray has been set so create a copy of the cols whose +# first and second level references can be clobbered. +# This assumes that the values side of the schema will +# always been hashrefs + my %cols_copy = %{$self->{schema}{cols}}; + for my $col_name (keys %cols_copy) { + + my %col_data = %{$cols_copy{$col_name}}; + $cols_copy{$col_name} = \%col_data; + + for (keys %col_data) { + if (ref $col_data{$_} eq 'HASH') { + $col_data{$_} = {%{$col_data{$_}}}; + } + elsif (ref $col_data{$_} eq 'ARRAY') { + $col_data{$_} = [@{$col_data{$_}}]; + } + } + } + + return %cols_copy; +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# Returns the primary key columns for the current table. In scalar context, +# returns undef to indicate no primary key, or an array reference of column +# names. In list context you get a list of column names, or an empty list if +# no primary key exists. +# +# $obj->pk($array_ref); +# ---------------------- +# Sets relation primary key, $array_ref is the reference to an array which +# looks like: +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# --------------------------------- +# Sets relation primary key given the fields which are in parameter. +# + my $self = shift; + my @pk; + if (@_ == 0) { + my @pk = @{$self->{schema}->{pk}}; + return wantarray ? @pk : @pk ? \@pk : undef; + } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + push @pk, @{$arg}; + } + elsif (not ref $arg) { + push @pk, $arg; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in $arg"); + } + } + else { + for (@_) { + if (not ref $_) { + push @pk, @_; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in @_"); + } + } + } + @{$self->{schema}->{pk}} = @pk; + return wantarray ? @{$self->{schema}->{pk}} : $self->{schema}->{pk}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# $obj->ai; +# --------- +# Returns the auto incriment column for the current +# table instance. +# +# $obj->ai($column); +# ------------------- +# Sets the AUTO INCREMENT column. +# + my ($self, $ai) = @_; + ref $ai and return $self->fatal(BADARGS => "Argument to ->ai cannot be a reference"); + $self->{schema}->{ai} = $ai if defined $ai; + return $self->{schema}->{ai} +} +END_OF_SUB + +$COMPILE{search_driver} = __LINE__ . <<'END_OF_SUB'; +sub search_driver { +# ----------------------------------------------------------- +# $obj->search_driver; +# -------------------- +# Returns the search driver column for the current +# table instance. +# +# can be 'INTERNAL', 'MYSQL', 'NONINDEXED' +# +# $obj->search_driver($column); +# ----------------------------- +# Sets the Searching Driver column. +# + my ($self, $search_driver) = @_; + $search_driver and ref $search_driver and return $self->fatal(BADARGS => "Argument to ->search_driver must not be a reference"); + $self->{schema}->{search_driver} = $search_driver if $search_driver; + if ( not defined $self->{schema}->{search_driver} ) { + my $indexer = $self->_get_indexer(1); + ( ref $indexer ) =~ /::(\w+)::Indexer$/; + $self->{schema}->{search_driver} = $1; + } + return $self->{schema}->{search_driver}; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns a hash in list context and a hash ref +# in scalar context. This hash contain the index +# name as the keys and an array ref as the values. +# The array ref contains the fields that are part of +# the index that is the key. +# +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{index} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->index(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->index(HASH_REF) or $obj->index') + } + } + else { + my $index_name = shift; + $self->{schema}->{index}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{index}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{index}}) { + ref $self->{schema}->{index}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index}; +} +END_OF_SUB + +sub subclass { +# ----------------------------------------------------------- +# $obj->subclass; +# --------------- +# Returns the subclass for the current table. +# This subclass is what the objects are blessed +# into. This makes it easy to subclass per table object. +# +# $obj->subclass($subclass); +# --------------------------- +# Sets the subclass. $subclass should be a hash +# reference or a hash. +# + my $self = shift; + my $opt; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{subclass}} : $self->{schema}->{subclass} } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift } + elsif (defined $_[0] and @_ % 2 == 0) { $opt = {@_} } + else { return $self->fatal(BADARGS => 'Usage: $obj->subclass(HASH or HASH_REF)') } + + for my $meth (qw/html relation table/) { + next unless exists $opt->{$meth}; + if (ref $opt->{$meth} ne 'HASH') { + return $self->fatal(BADARGS => 'The hash that is passed into subclass() must be a hash of hashes'); + } + my $val = {}; + my $prefix = $self->{connect}->{PREFIX}; + for (keys %{$opt->{$meth}}) { + my $v = $_; + if (length $prefix) { + unless (/^$prefix/) { + $v = $prefix . $v; + } + } + $val->{$meth}->{$v} = $opt->{$meth}->{$_}; + } + $self->{schema}->{subclass}->{$meth} = $val->{$meth}; + } + return 1; +} + +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns a hash in list context and a hash ref +# in scalar context. This hash contains the unique +# index names as the keys and array refs as the values. +# The array refs contain the fields that are part of +# the unique index. +# +# $obj->unique($index_name, $col1, ..., $coln); +# --------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{unique} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->unique(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->unique(HASH_REF) or $obj->unique') + } + } + else { + my $index_name = shift; + $self->{schema}->{unique}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{unique}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{unique}}) { + ref $self->{schema}->{unique}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + + return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique}; +} + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# Returns a hash in list content and a hash ref in scalar +# context. This hash ref contains the foreign table as the +# key and a hash ref as the value. The hash ref has keys as +# the field in the current table that relates to fields in +# the foreign table. The values are the fields in the foreign +# table that the fields in this table relate to. +# +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_2, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ---------------------------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +# + my $self = shift; + @_ or return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; + + my %set; + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + %set = %$arg; + } + else { + return $self->{schema}->{fk}->{$arg}; + } + } + elsif (@_ == 2 and ref $_[1] eq 'HASH') { + %set = @_; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->fk(TABLE_NAME, HASH_REF or HASH_REF) or $obj->fk'); + } + my $prefix = $self->{connect}->{PREFIX}; + for my $table (keys %set) { + my $prefixed = $table; + $prefixed = $prefix . $prefixed if length $prefix and $table !~ /^\Q$prefix/; + $self->{schema}->{fk}->{$prefixed} = $set{$table}; + } + +# Make sure the arguments passed in were correct. + for my $ftable (keys %{$self->{schema}->{fk}}) { + ref $self->{schema}->{fk}->{$ftable} eq 'HASH' or return $self->fatal(BADARGS => "fk must contain a hash of hashes"); + } + + $self->_update_fk_tables or return; + + return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# Used to set the tables that reference this one. +# + my $self = shift; + if (@_ == 0) { return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables} } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + $self->{schema}->{fk_tables} = [@$arg]; + } + else { + @{$self->{schema}->{fk_tables}} = ($arg); + } + } + else { + @{$self->{schema}->{fk_tables}} = @_; + } + for (@{$self->{schema}->{fk_tables}}) { + if (ref $_) { + return $self->fatal(BADARGS => "Arguments to fk_table must be scalars"); + } + } + my $prefix = $self->{connect}->{PREFIX}; + for (@{$self->{schema}->{fk_tables}}) { + if (length $prefix) { + unless (/^$prefix/) { + $_ = $prefix . $_; + } + } + } + return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables}; +} +END_OF_SUB + +$COMPILE{tree} = __LINE__ . <<'END_OF_SUB'; +sub tree { +# ----------------------------------------------------------- +# An accessor for the GT::SQL::Tree object associated with +# this table. Creating/dropping a tree is done through the +# table editor. If no tree exists, you get undef and a warning +# occurs. + my $self = shift; + return $self->warn(NOTREE => $self->name()) unless ($self->{schema}->{tree}); + if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"}) { + $self->debug("Returning GT::SQL::Tree object for table $self->{name} from cache") if $self->{_debug}; + return $cached; + } + + require GT::SQL::Tree; + $self->debug("Creating new GT::SQL::Tree object for table " . $self->name()) if $self->{_debug}; + my $tree = GT::SQL::Tree->new({ + table => $self, + debug => $self->{_debug} + }); + + if ($self->{connect}->{obj_cache}) { + $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"} = $tree; + } + + return $tree; +} +END_OF_SUB + +$COMPILE{check_schema} = __LINE__ . <<'END_OF_SUB'; +sub check_schema { +# ----------------------------------------------------------- +# Checks the current table schema for inconsistencies in the +# structure. +# + my $self = shift; + my %cols = %{$self->{schema}->{cols}}; + +# Go through each column and check them + for my $col (keys %cols) { +# Make sure we have a position field. + if (! exists $cols{$col}->{pos}) { + $self->debug("Trying to create a column that does not have a position field.") if $self->{_debug}; + return $self->fatal(NOPOS => $col); + } + +# Primary key cannot be a "text" or "blob" type and must be "not null". + if ($self->_is_pk($col)) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("Trying to use a primary key without making it not null. Adding not_null to $col") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(PKTEXT => $col); + } + } + +# Unique must be "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{unique}}) { + if (grep /^\Q$col\E$/, @{$self->{unique}->{$_}}) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("unique key $col is not NOT_NULL. Adding to NOT_NULL") if ($self->{_debug}); + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(UNIQTEXT => $col); + } + } + } + +# Index must ne "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{index}}) { + if (grep /^\Q$col\E$/, @{$self->{schema}->{index}->{$_}}) { + unless ($self->_is_not_null($col)) { + $self->debug("index key $col is not NOT_NULL. Adding to NOT_NULL") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(INDXQTEXT => $col) if $self->{_debug}; + } + } + } + +# Autoincrement must be an "INT" type and must be the only "PRIMARY KEY" + $self->{schema}->{ai} ||= ''; + if ($col eq $self->{schema}->{ai}) { + if ($cols{$col}->{type} !~ /INT/i) { + return $self->fatal(AINOTPK => $col); + } + if (!$self->_is_pk($col) or @{$self->{schema}->{pk}} > 1) { + $self->debug("AUTO_INCREMENT column $col specified but is not the primary key. Making $col primary key.") if $self->{_debug}; + @{$self->{schema}->{pk}} = ($col); + } + } + +# File columns must point to exisiting directories where we have write access! + if ($cols{$col}->{form_type} and uc $cols{$col}->{form_type} eq 'FILE') { + $cols{$col}->{file_save_in} or return $self->fatal(NOFILESAVEIN => $col); + return $self->fatal(NODIRPRIV => $cols{$col}->{file_save_in}) + unless -w $cols{$col}->{file_save_in}; + } + } + +# Circularity check + $self->_circularity_check or return undef; + + return 1; +} +END_OF_SUB + +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { +# ----------------------------------------------------------- +# $obj->ordered_columns; +# ---------------------- +# Returns the current table columns ordered +# in function of the "pos" type of a given +# column. +# +# The columns having no specified pos are +# appended in lexicographical order at the +# end of the result array. +# + my $self = shift; + my @cols = (); + my @append = (); + my $cols = $self->{schema}->{cols}; + for my $col (sort { + $cols->{$a}->{pos} && $cols->{$b}->{pos} ? $cols->{$a}->{pos} <=> $cols->{$b}->{pos} : + $cols->{$a}->{pos} && !$cols->{$b}->{pos} ? -1 : + $cols->{$b}->{pos} && !$cols->{$a}->{pos} ? 1 : + ($a cmp $b) + } keys %{$cols}) { + push @cols, $col; + } + + return @cols; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + my @keys = map { @$_ } values %{$self->unique}, values %{$self->index}; + return wantarray ? @keys : \@keys; +} +END_OF_SUB + +$COMPILE{save_def} = __LINE__ . <<'END_OF_SUB'; +sub save_def { shift->save_state(@_) } +END_OF_SUB + +$COMPILE{save_state} = __LINE__ . <<'END_OF_SUB'; +sub save_state { +# ----------------------------------------------------------- +# $obj->save_state; +# ---------------------------- +# Saves table structure in $self->{connect}->{def_path}/table.def, and +# deletes the table from the object cache. +# + my $self = shift; + $self->debug("Saving state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + $self->{schema}->save(); + $self->debug("State saved for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + + my $cache_key = join("\0", 'TABLE', $self->{name}, $self->{connect}->{def_path}); + delete $GT::SQL::OBJ_CACHE{$cache_key}; + + return 1; +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# ------------------------------------------------------------------- +# $obj->file('ColumnName', $primary_key); +# ------------------------------ +# Returns the file associated with the column +# + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->file_info(@_); +} +END_OF_SUB + +$COMPILE{file_rescan} = __LINE__ . <<'END_OF_SUB'; +sub file_rescan { +# ------------------------------------------------------------------- + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->rescan(); +} +END_OF_SUB + +sub check_values { +# ------------------------------------------------------------------- +# Checks to see that the values for an insert are legal to +# be inserted. Returns false on error true on success +# + my ($self, $set) = @_; + +# Check to ensure the values are valid + my %cols = %{$self->{schema}->{cols}}; + my $ai = $self->{schema}->{ai}; + for my $col (keys %$set) { + next if ($ai and $ai eq $col); + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join $GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}; + } + $self->_check_value($col, $cols{$col}, $set->{$col}); + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +# -------------------------------------------------------------------------------------- # +# PRIVATE FUNCTIONS # +# -------------------------------------------------------------------------------------- # +$COMPILE{_update_fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub _update_fk_tables { +# ------------------------------------------------------------------- +# Updates all the tables fields that +# this tables is referenced by. +# + my $self = shift; + for my $table (keys %{$self->{schema}->{fk}}) { + my $foreign_table = $table eq $self->{name} + ? $self + : ($self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error)); + $foreign_table->_add_fk_table($self->{name}) + and $foreign_table->save_state(); + } + return 1; +} +END_OF_SUB + +$COMPILE{_add_fk_table} = __LINE__ . <<'END_OF_SUB'; +sub _add_fk_table { +# ----------------------------------------------------------------------------- +# Takes a foreign table name. The foreign table is added if it doesn't already +# exist in $self's fk_tables schema. Any duplicates are removed. This is to +# prevent the same table appearing several times in fk_tables. You still need +# to ->save_state() after calling this. Returns 1 if anything changed, undef +# otherwise. +# + my ($self, $add) = @_; + my %have = map { $_ => 1 } @{$self->{schema}->{fk_tables}}; + push @{$self->{schema}->{fk_tables}}, $add unless $have{$add}; + return $have{$add} ? undef : 1; +} +END_OF_SUB + +$COMPILE{_circularity_check} = __LINE__ . <<'END_OF_SUB'; +sub _circularity_check { +# ------------------------------------------------------------------- +# This function loops through all the tables in the current +# databases. If a circular reference is detected, then a +# warning is printed and FALSE is returned. If no circular +# references are detected, TRUE is returned. +# + my $self = shift; + my (%cols, @tables, %tables); + + return 1 unless keys %{$self->{schema}->{fk}}; # If there are no foreign keys there is nothing to do. + + my $name = $self->name; + + @tables = $name; + $tables{$name}++; + + for (my $i = 0; $i < @tables; $i++) { + return $self->fatal('CIRCULARLIMIT') if $i >= 100; + + my $table = $tables[$i]; + my $new = ($table eq $name) ? $self : $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + for my $table_name (keys %{$new->{schema}->{fk}}) { + my %this; # Allows for multiple fk's from the same table to the same key + for my $column (keys %{$new->{schema}->{fk}->{$table_name}}) { + my $tc = "$table: $table_name.$new->{schema}->{fk}->{$table_name}->{$column}"; + $self->debug("Found foreign key in $tc") if $self->{_debug}; + if (not $this{$tc}++ and $cols{$tc}++) { + $self->debug("$tc was already found!") if $self->{_debug}; + return $self->warn(CIRCULAR => $tc); + } + splice @tables, $i + 1, 0, $table_name unless $tables{$table_name}++; + } + } + } + + return 1; +} +END_OF_SUB + + +$COMPILE{_check_timestamp} = __LINE__ . <<'END_OF_SUB'; +sub _check_timestamp { +# ------------------------------------------------------------------- +# Won't modify a record if the passed in timestamp is older than +# what's in the database. +# + my ($self, $keys, $set) = @_; + +# first check to see if we even need to look up the orig timestamp. + my $auto = $self->time_check; + return 1 unless ($auto); + my $found = 0; + for (keys %$auto) { + exists $set->{$_} and ($found = 1); # should only be one timestamp. + } + return 1 unless ($found); + +# if we got here, then we do a search on the record and compare timestamp. + my $pk = $self->{schema}->{pk}; + my $cond = GT::SQL::Condition->new; + my @res; + for my $key (@$pk) { + $cond->add($key, "=", $keys->{$key}); + } + for my $tmstmp (keys %$auto) { + push @res, $tmstmp; + $cond->add($tmstmp, ">", $set->{$tmstmp}); + delete $set->{$tmstmp}; + } + my $sth = $self->select($cond, \@res) or return; + if ($sth->fetchrow_arrayref) { + return $self->warn('ALREADYCHANGED'); + } + else { + return 1; + } +} +END_OF_SUB + +sub _check_insert { +# ------------------------------------------------------------------- +# Check to make sure an insert is properly set up. +# + my ($self, $set, $cond) = @_; + my @indexes; + my %indx_hash = $self->unique; + push @indexes, values %indx_hash if (keys %indx_hash); + +# Add the primary key to the list of uniques + if (@{$self->{schema}->{pk}} and ! $self->{schema}->{ai}) { + push @indexes, $self->{schema}->{pk}; + } + +# Check that columns that aren't in the insert are not not_null columns. This +# check is done here rather than in _check_value() because _check_value() is +# also used by update(). _check_value() will handle all other not_null cases. + while (my ($c, $col) = each %{$self->{schema}->{cols}}) { + next if exists $set->{$c}; + my $default = $col->{default}; + if ($col->{not_null} and # Only check for not_null columns + (not $self->{schema}->{ai} or $c ne $self->{schema}->{ai}) and # But not the auto-increment field + (not defined $default or $default eq '')) { # And only when there isn't a default + $self->warn(NOTNULL => $col->{form_display} || $c); + } + } + +# Check that the unique columns are really unique. + my $check = {}; + INDEX: for my $index (@indexes) { + my $check = {}; + COL: for my $col (@$index) { + next INDEX if ($col eq $self->{schema}->{ai}); + $check->{$col} = $set->{$col}; + } + my $rows = $self->count($check); + if ($rows) { + $self->warn(UNIQUE => join(",", map $self->{schema}->{cols}->{$_}->{form_display} || $_, keys %$check), join(",", values %$check)); + } + } +# Check the values to make sure they are ok. + $self->check_values($set); + +# Join the list of errors. + my @errors = (ref($self->{_error}) and @{$self->{_error}}) ? @{$self->{_error}} : (); + if (@errors) { + $GT::SQL::error = join "\n", @errors; + return; + } + return 1; +} + +sub _check_update { +# ------------------------------------------------------------------- +# Checks to see if any of the set options +# are unique. If they are does a select +# on the table. If the condition tests +# true returns undef. The error will be set in +# the package error variable. +# + my ($self, $set, $cond) = @_; + +# Turn off warning here (too much work to remove unitialized values from +# returned data). + local $^W = 0; + +# Ensure that columns that are NOT NULL have not been specified as null + my %cols = %{$self->{schema}->{cols}}; + for my $col (keys %{$set}) { + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}); + } + $self->_check_value($col, $cols{$col}, $set->{$col}) or return; + } + my %indx_hash = $self->unique; + my @indexes = values %indx_hash; + +# Add the primary key to the list of uniques + my $pk = $self->{schema}->{pk}; + $pk = ref $pk ? $pk : [$pk]; + push @indexes, $pk unless $self->{schema}->{ai}; + +# If there are no uniques, then return previous errors, or return 1. + if (! @indexes) { + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } + } +# If the update isn't changing any unique columns, then there's no need to +# perform the select later in the code. + else { + my $updates_unique; + INDEX: for my $index (@indexes) { + for (@$index) { + if (exists $set->{$_}) { + $updates_unique = 1; + last INDEX; + } + } + } + return 1 unless $updates_unique; + } + +# Only request what has changed plus the primary key and any uniques + my %changes = (); + for (keys %$set) { $changes{$_} = 1 } + for (@$pk) { $changes{$_} = 1 } + for my $index (@indexes) { + for (@$index) { + $changes{$_} = 1; + } + } + +# Fetch records to make sure we don't break a unique clause. + my $sth = $self->select(keys(%changes), $cond) or return; + my @marked = (); + RECORD: while (my $rec = $sth->fetchrow_hashref) { + +# Go through all the indexes for this table + for my $i (0 .. $#indexes) { + +# A hash to build the count query out of + my $count_check = {}; + +# If the record is different than the one in the database + my $match = 0; + for (@{$indexes[$i]}) { + if (defined $set->{$_} and $set->{$_} ne $rec->{$_}) { + $match = 1; + } + $count_check->{$_} = $set->{$_}; + } + +# It was not different so we continue to the next set of uniques + $match or next; + +# It was different so we need to make a count select to see if it is possible +# to do this insert + if ($self->count($count_check)) { + +# the count returned true so there was a duplicate record + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# The count returned false so there was not a duplicate record +# so if the record is already marked we return false + if ($marked[$i]) { + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# else we mark the record. + $marked[$i] = 1; + } + } + } + } + +# Everything should have went fine so return true the record is +# insertable. + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } +} + +sub _check_value { +# ------------------------------------------------------------------- +# Checks to see if a value is valid. +# + my ($self, $name, $column, $value) = @_; + + my $regex = ''; + if ($column->{not_null} and not defined $value) { + $self->warn(NOTNULL => $column->{form_display} || $name); + } + if ($column->{type} eq 'ENUM' and $value) { + $regex = '^(?:' . join('|', map quotemeta, @{$column->{values}}) . ')$'; + } + elsif (defined $value) { + unless ($regex = $column->{regex}) { + my $sign = $column->{unsigned} ? '\+' : '[+-]'; + if ($column->{type} eq 'INTEGER' or $column->{type} =~ /INT$/) { + $regex = '^' . $sign . '?\d+$'; + } + elsif ($column->{type} =~ /^(?:REAL|FLOAT|DOUBLE|DECIMAL)$/) { + $regex = '^' . $sign . '?(?=\d|\.\d)\d*(\.\d*)?(?:[eE][+-]?\d+)?$'; + } + } + } + + if ($regex and not ref $value) { + if (eval { $value !~ /$regex/ }) { + $self->warn(ILLEGALVAL => $column->{form_display} || $name, $value); + } + elsif ($@) { + $self->warn(REGEXFAIL => $regex); + } + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +sub _extract_where { +# ------------------------------------------------------------------- +# Takes the users input and extracts the +# hash refs or condition clause. Creates +# a Condition object and returns it. +# Returns where the query was a hash or not +# as well. +# + my @args = @_; + my $cond = GT::SQL::Condition->new; + my $do_select = 0; + for (@args) { + if (ref eq "HASH") { + while (my ($col, $val) = each %$_) { + $cond->add($col => '=' => $val); + } + } + elsif (ref eq 'GT::SQL::Condition') { + $do_select = 1; + $cond->add($_->clone); + } + } + return ($cond, $do_select); +} + +sub _build_cond { +# ------------------------------------------------------------------- +# this subroutine is done to build conditions +# which may not be a Condition +# for selects and deletes. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond->clone; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + for my $key (keys %{$cond}) { + next unless exists $cols->{$key}; + if (ref $cond->{$key} eq 'ARRAY') { + $tmp->add($key => IN => $cond->{$key}); + } + elsif (defined $cond->{$key}) { + $tmp->add($key => '=' => $cond->{$key}); + } + else { + $tmp->add($key => 'IS' => \'NULL'); + } + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition(@$cond); + return $tmp->clone; + } + $self->fatal(BADARGS => "_build_cond takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +sub _build_set { +# ------------------------------------------------------------------- +# Internal use. Builds the set options for the query. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + $tmp->bool(','); + for my $key (keys %{$cond}) { + $tmp->add($key, "=", $cond->{$key}) if exists $cols->{$key}; + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$cond}, ','); + return $tmp; + } + $self->fatal(BADARGS => "_build_set takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +$COMPILE{_check_keys} = __LINE__ . <<'END_OF_SUB'; +sub _check_keys { +# ------------------------------------------------------------------- +# Checks to see if the arguments passed into +# delete contains the externally linked columns +# + my ($self, $where) = @_; + ref $where or return $self->fatal(BADARGS => '_check_keys'); + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for ($self->fk_tables) { + my $new_schema = $self->new_table($_) or return $self->fatal(FKNOTABLE => $_, $GT::SQL::error); + my %hash = $new_schema->fk; + my $name = $self->name; + + for (values %{$hash{$name}}) { + return unless exists $cond->{$_}; + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_do_opt} = __LINE__ . <<'END_OF_SUB'; +sub _do_opt { +# ------------------------------------------------------------------- +# Does a select or delete based on the option +# + my ($self, $opt, $sel_hashr, $table_name) = @_; + my $new_me = $self->new_table($table_name) or return $self->fatal(FKNOTABLE => $table_name, $GT::SQL::error); + if ($opt eq 'cascade') { + my $cond; + if ($self->{schema}->{tree} and keys %$sel_hashr > 1 and $self->tree->{tree}->name() eq $new_me->name()) { + $cond = []; + for (keys %$sel_hashr) { + push @$cond, GT::SQL::Condition->new($_ => '=' => $sel_hashr->{$_}); + } + } + else { + $cond = $sel_hashr; + } + if (ref $cond eq 'ARRAY') { + for (@$cond) { + $new_me->delete($_) or return; + } + } + else { + $new_me->delete($cond) or return; + } + } + else { + return $self->warn(DEPENDENCY => $table_name) if $new_me->count($sel_hashr); + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cond} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cond { +# ------------------------------------------------------------------- +# Performs the delete based on a condition object +# + my ($self, $where, $opt) = @_; + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + while (my ($k, $v) = each %$fk_href) { + $sel_hashr->{$k} = $cond->{$v} if exists $cond->{$v}; + } + + return $self->fatal(FKMISSING => $fktable, $self->name, $fktable) unless keys %$sel_hashr; + $self->_do_opt($opt, $sel_hashr, $fktable) or return; + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_select} = __LINE__ . <<'END_OF_SUB'; +sub _delete_select { +# ------------------------------------------------------------------- +# Performs the delete based on the cascade +# option +# + my ($self, $sth, $opt) = @_; + my $fk_del; + my $data = $sth->fetchall_hashref; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + for my $row (@$data) { + for my $fk (keys %$fk_href) { + push @{$sel_hashr->{$fk}}, $row->{$fk_href->{$fk}}; + } + } + $self->_do_opt($opt, $sel_hashr, $fktable) or return if keys %$sel_hashr; + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cleanup} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cleanup { +# ------------------------------------------------------------------- +# Performs the delete based on one to many relationship. +# + my ($self, $where) = @_; + +# Get the SQL. + my $sth = $self->select($where); + + my $rows = $sth->fetchall_arrayref(); + return 0 unless $rows and @$rows; + + $sth = $self->{driver}->delete($where) or return; + + my $name = $self->name; + for my $fk_table ($self->fk_tables) { + + my $new_schema = $self->new_table($fk_table) or return $self->fatal(FKNOTABLE => $fk_table, $GT::SQL::error); + my %fk = $new_schema->fk; + my @ls = sort keys %{$fk{$name}}; + my $rel = $self->new_relation($fk_table, $self->name); + my %cond; + for my $col (@ls) { + my $c = $fk{$name}->{$col}; + $cond{"$name.$c"} = undef; + my @sel_limit = map $_->[$self->{schema}->{cols}->{$c}->{pos} - 1], @$rows; + next unless @sel_limit; + $cond{"$fk_table.$col"} = \@sel_limit; + } + my $sth = $rel->select('left_join', @ls, \%cond) or return; + my $cols = $new_schema->cols; + + my $pk_vals = $sth->fetchall_arrayref; + if (@ls > 1) { + for my $row (@$pk_vals) { + $new_schema->delete({ map { ($ls[$_] => $row->[$_]) } 0 .. $#ls }) or return; + } + } + elsif (@ls == 1) { + my @del = map $_->[0], @$pk_vals; + $new_schema->delete({ $ls[0] => \@del }) if @del; + } + } + return 1; +} +END_OF_SUB + +# Returns a hash of all columns that have positive weights. +$COMPILE{_weight_cols} = __LINE__ . <<'END_OF_SUB'; +sub _weight_cols { + my $self = shift; + return map { + $self->{schema}->{cols}->{$_}->{weight} + ? ($_ => $self->{schema}->{cols}->{$_}->{weight}) + : () + } keys %{$self->{schema}->{cols}}; +} +END_OF_SUB + +# a hash of all columns that have form_type file +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { + my $self = shift; + $self->{_file_cols} = { + map { + ($self->{schema}->{cols}->{$_}->{form_type} and uc $self->{schema}->{cols}->{$_}->{form_type} eq 'FILE') + ? ($_ => $self->{schema}->{cols}->{$_}) + : () + } keys %{$self->{schema}->{cols}} + } if !$self->{_file_cols} or shift; + + %{$self->{_file_cols}}; +} +END_OF_SUB + +# Returns true if first argument is a primary key. +$COMPILE{_is_pk} = __LINE__ . <<'END_OF_SUB'; +sub _is_pk { + for (@{$_[0]->{schema}->{pk}}) { + return 1 if $_ eq $_[1]; + } + return 0; +} +END_OF_SUB + +$COMPILE{_is_fk} = __LINE__ . <<'END_OF_SUB'; +sub _is_fk { +# ------------------------------------------------------------------- +# Returns true if first argument is a foreign key. +# + for (keys %{$_[0]->{schema}->{fk}}) { + return 1 if exists $_[0]->{schema}->{fk}->{$_}->{$_[1]}; + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is not null. +$COMPILE{_is_not_null} = __LINE__ . <<'END_OF_SUB'; +sub _is_not_null { + return( + exists $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + and $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + ); +} +END_OF_SUB + +# Returns true if first argument is indexed. +$COMPILE{_is_indexed} = __LINE__ . <<'END_OF_SUB'; +sub _is_indexed { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{index}}) { + for my $index_col (@{$self->{schema}->{index}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is uniquely indexed. +$COMPILE{_is_unique} = __LINE__ . <<'END_OF_SUB'; +sub _is_unique { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{unique}}) { + for my $index_col (@{$self->{schema}->{unique}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if ($self->{_debug} > 2); + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self + ); + $indexer->debug_level($self->{_debug}); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Table - a perl interface to manipulate a single SQL table. + +=head1 SYNOPSIS + + my $sth = $table->select(Column3 => { Column => $value, Column2 => $value2 }); + $table->delete({ Column => $value }); + $table->insert({ Column1 => $val, Column2 => $value2 }); + $table->update({ SetCol => $val }, { WhereCol => $val2 }); + +=head1 DESCRIPTION + +GT::SQL::Table provides methods to add, modify, delete and search over a single +SQL table. + +The following methods are provided. + +=head2 query, query_sth + +C provides a simple and powerful method to search a table. It takes as +input either a hash, hash ref or CGI object making it especially useful +searching from web forms. + + my $results = $db->query($in); + +The return of C is an arrayref of arrayrefs. C returns an STH +that you can fetch rows from. + +Typical usage to go through the results is: + + my $results = $db->query({ Title => 'foobar' }); + if ($results) { + for my $result (@$results) { + ... + } + } + +To specify what to search, you simply pass in column => search value. However, +you can also pass in a lot of options to enhance your search: + +Find all rows with field_name = value: + + field_name => value + +Find all rows with field_name > value: + + field_name => ">value" + +Find all rows with field_name < value: + + field_name => " value: + + field_name-gt => value + +Find all rows with field_name < value: + + field_name-lt => value + +Find all rows where any field_name = value: + + keyword => value + +Find all rows using indexed search (see weights): + + query => value + +Set to 1, use '=' comparison, 0/unspecified use 'LIKE '%val%' comparision: + + ww => 1 + +Search using LIKE for column 'Title' (valid opts are '=', '>', '<' or 'LIKE'): + + Title-opt => 'LIKE' + +Set to 1, OR match results, 0/unspecified AND match results: + + ma => 1 + +Return a max of n results, defaults to 25: + + mh => n + +Return page n of results: + + nh => n + +Sort by 'Title' column: + + sb => 'Title' + +Sort in ascending (ASC) or descending (DESC) order: + + so => 'ASC' + +=head2 select + +Select provides a way to implement almost any sql SELECT statement. + +An executed statement handle is returned that you can call the normal fetchrow, +fetchrow_array, fetchrow_hashref, etc on. + + my $sth = $obj->select; + +is equivalant to "SELECT * FROM Table" + + my $sth = $obj->select({ Col => Val }); + +is equivalant to "SELECT * FROM Table WHERE Col = 'Val'". + + my $sth = $obj->select('Col2', 'Col3', { Col => "Val" }); + +is equivalant to "SELECT Col2,Col3 FROM Table WHERE Col => 'Val'". + +So you can pass in a hash reference which represents the where clause, and an +array reference where represents what you want to select on. + +If you need more complex where clauses, you should use a condition object +instead of a hash reference. See L for more information. + +Notes: + +=over 4 + +=item quoting in where + +All arguments in the where clause are automatically quoted. If you don't want +quotes, you should pass in a scalar reference as in: + + my $sth = $obj->select({ Col => \"NOW()" }); + +which turns into "SELECT * FROM Table WHERE Col = NOW()". + +=item quoting in select + +Nothing in the select will be quoted, so to use functions, simply pass in what +you want: + + my $sth = $obj->select('COUNT(*)'); + +which turns into "SELECT COUNT(*) FROM Table". + +=back + +To specify LIMIT, or GROUP BY, or ORDER BY or other SELECT clauses that come +after the WHERE, you should use select_options below. + +=head2 select_options + +This method provides a way for you to specify select options such as LIMIT and +SORT_BY. + + $obj->select_options(@OPTIONS); + +@OPTIONS should be a list of options you want appended to your next select. + +For example, + + $obj->select_options('ORDER BY Foo', 'LIMIT 50'); + $obj->select; + +would turn into "SELECT * FROM Table ORDER BY Foo LIMIT 50". To perform a +LIMIT with an OFFSET, you should specify something like: + + $obj->select_options('LIMIT 25 OFFSET 75'); + +You can alternatively use the equivelant MySQL-specific syntax: + + $obj->select_options('LIMIT 75, 25'); + +Both will be handled correctly regardless of the database type. + +=head2 count + +This method will allow you to count records based on a where clause. + + my $count = $obj->count($condition); + +count() takes either a condition or a hash reference. If no argument is +provided, it is equivalant to "SELECT COUNT(*) FROM Table", or total number of +rows. + +=head2 hits + +This method returns the number of hits from that last select query B +the limit clause if there was one. + + $hits = $obj->hits; + +For example, to get rows 20-30 of a query result, use: + + $obj->select_options("LIMIT 10 OFFSET 20"); $obj->select({ Column => 'Foo' }); + +this translates into (in MySQL): + + SELECT * FROM Table WHERE Column = 'Foo' LIMIT 20, 10 + +To see the total number of results that the query would have retrieved without +any limit, you call: + + $hits = $obj->hits; + +If the number of hits can be calculated, it will be returned to you without any +additional query. Otherwise, the following query will be performed +automatically, and the hit count returned to you: + + SELECT COUNT(*) FROM Table WHERE Column = 'Foo' + +B: The hits() method _only_ applies to select queries. Most databases do +not provide enough information to get counts of rows affected for other types +of queries. + +=head2 get + +This method allows for a simple interface to retrieving records from the +table(s). + + my $rec_hash_ref = $obj->get($val); + my $rec_hash_ref = $obj->get($val, 'HASH', ['col1', 'col2']); + my $rec_array_ref = $obj->get($val, 'ARRAY'); + +The first argument is the primary key value of the record you want to retrieve. + +The second argument is a format option. It can be either 'ARRAY' or 'HASH' and +determines whether you are returned a HASH reference or an ARRAY reference. The +default is 'HASH', and it is optional. + +The last argument is a list of column names you want retrieved. C defaults +to returning the entire record, but if you only need specific columns, you can +ask for the ones you want. + +For example: + + my $employee = $emp_db->get('Alex'); + +would return a hash ref of the record whose primary key is equal to 'Alex'. + + my $emp_addr = $emp_db->get('Alex', 'HASH', ['City', 'State', 'ZipCode']); + +would return a hash ref of only the three fields City, State, ZipCode for the +record whose primary key equals Alex. + +=head2 add + +Method to add an entry into the database. This method can take it's arguments +one of three ways. + + $obj->add($CGI_OBJECT); + + -or- + + $obj->add({ + col1 => $val1, + col2 => $val2, + ... + }); + + -or- + + $obj->add( + col1 => $val1, + col2 => $val2, + ... + ); + +This method can take a cgi object, a hash reference or a hash. The keys of the +hash should be the names of the column and the values should be the values to +insert into the fields. The CGI Object is not different. If the table has an +auto_increment field, the value of the last inserted record will be returned. + +C returns undef on failure. If successful, and the table has an +auto-increment field, the auto increment value is returned. If there is no +auto increment value, then 1 is returned. Any errors will be in +$GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 will have the table module skip any error +checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 insert + +C is a lower level add. The main differences between C and +C are that add performs a not null check, and add returns the id of the +just inserted value. + +C does not perform a not null check. Also, insert returns the statement +handle used to do the insert (so you can call $sth->insert_id to get the auto +increment). + +=head2 insert_multiple + +C will try to optimize the insertion of multiple rows with +simple values. Under MySQL, this uses MySQL's extended insert syntax: + + INSERT INTO Table (col1, col2, col3) + VALUES ('val1', 'val2', 'val3'), ('val4', 'val5', 'val6'), ... + +On other databases, it attempts to perform all insertions in a single +transaction, which will also usually yield performance benefits. Note, +however, that C should not be used for anything more complex +than basic column values - for example, inserting NULL to set the current date, +or using raw SQL by passing scalar references for values. + +It takes at least two arguments - the first argument is an array ref of column +names, and the rest are array references of values. For example, to produce +the above example SQL code, you would call: + + $table->insert_multiple( + ['col1', 'col2', 'col3'], + ['val1', 'val2', 'val3'], + ['val4', 'val5', 'val6'], + ... + ); + +=head2 modify + +This method is designed for modifying a single entry in the table. It takes as +input a hash, hash ref or CGI object, which is assumed to represent a single +row with all fields intact. + +C will then look for the primary key in the input and set all fields +for that row equal to what was passed in. + +You need to pass in a complete record! If you just want to update one column, +you probably want to use C instead, as doing: + + my $result = $obj->modify(column1 => 'Foo'); + +will blank out all the other fields and set just column1 to Foo. + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 update + +This method provides a more robust way to update multiple entries in the table. + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + $condition + ); + + -or- + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + { + col1 => $val1, + col2 => $val2, + ... + } + ); + +In both these cases the first argument is a hash reference with the column +names as the keys and the new values you want the columns to hold as the +values. The second argument can either be a condition object or a hash +reference. If it is a hash reference the keys will be used as the column names +and the values will be taken as the current column values for the where clause +to update the table. + + $obj->update({ Setme => 'NewValue'}, { WhereCol => 5 }); + +would set the column 'Setme' to 'NewValue' where the column 'WhereCol' is 5. +This translates to: + + UPDATE Table SET SetMe='NewValue' WHERE WhereCol = 5 + +If the second argument is a GT::SQL::Condition object the condition object will +be used to build the where clause with. Please see L for a +description of what you can do with a where clause. + + my $condition = GT::SQL::Condition->new('WhereCol', 'LIKE', 'Foo%'); + $obj->update({ Setme => 'Newvalue' }, $condition); + +would translate to: + + UPDATE Table SET Setme = 'Newvalue' WHERE WhereCol LIKE 'Foo%' + +The condition can now much more complex where clauses though. + +C returns undef on failure and the a L statement +handle on success. The error message will be available in $GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 as a third option to C will have the +table module skip any error checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 delete + +This method provides a robust interface to delete entries from your table(s) +using join and or foreign key relations. + + my $result = $obj->delete($condition); + +You can pass into C either a condition object to delete multiple +entries, or a scalar value to delete the row whose primary key equals the +value. If you have a multiple primary key, then you can pass in an array ref to +delete that row. + + my $result = $obj->delete({ + col1 => $val1, + col2 => $val2, + ... + ); + + -or- + + $obj->delete($val); + + -or- + + $obj->delete([$val1, $val2]); + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 delete_all + +This method takes no arguments and will erase all entries from a table. + +=head2 Table Properties + +Table provides a lot of methods to access information about the table: + +=over 4 + +=item name + +Provides the name of the table minus any prefix. + +=item ai + +Returns the name of the auto-increment field if any. + +=item pk + +Returns an array(ref) of primary key column names. + +=item fk + +Returns a hash of foreign key values. + +=item fk_tables + +Returns a list of tables with foreign keys pointing to this table. + +=item index + +Returns a hash ref of index name => array ref of column names that index uses. + +=item unique + +Returns a hash ref of unique index names => array ref of column names that +unique index uses. + +=item B + +Returns the joined output of index and unique and primary key. + +=item cols + +Returns a hash(ref) of column name => column definition + +=item default + +Returns a hash(ref) of column name => default value. + +=item size + +Returns a hash(ref) of column name => size of column in SQL. + +=item type + +Returns a hash(ref) of column name => type of column in SQL. + +=item form_display + +Returns a hash(ref) of column name => name to display on auto generated forms +(think pretty name). + +=item form_size + +Returns a hash(ref) of column name => size of html form to generate. + +=item form_type + +Returns a hash(ref) of column name => type of html form to generate (checkbox, +select, text, etc). + +=item form_names + +Returns a hash(ref) of column name => array ref of form names. This is used for +multi option form elements like checkboxes and multi selects. The name is what +is displayed to the user and not entered in the database. + +=item form_values + +Returns a hash(ref) of column name => array ref of form values. Same as above, +but this is the value that actually gets entered. + +=item time_check + +Returns a hash(ref) of column name => time check on or off. If set + +=item regex + +Returns a hash(ref) of column name => regular expression that all input must +pass before being inserted. + +=item pos + +Returns a hash(ref) of column name => position in table. + +=item not_null + +Returns a hash(ref) of column name => not null (whether the field is allowed to +be null or not). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Table.pm,v 1.274 2008/09/17 19:35:24 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree.pm new file mode 100644 index 0000000..6f9fe46 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree.pm @@ -0,0 +1,1269 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Tree.pm,v 1.30 2008/06/11 06:55:26 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to manage a tree structure in a table. +# +# +# The comments through this document reference "record hash refs" - +# a record hash ref consists of 5 keys: +# - tree_id_fk => the ID +# - tree_anc_id_fk => the ancestor ID +# - tree_dist => The 'distance' between the id and the ancestor. If the +# ancestor is the father, this is 1; for the grandfather, 2 +# +# Most things have a common return, which looks like this: +# { id => [{ record }, { record2 }, { record3 }], id2 => [], ... } +# Where id, id2, ... are the ID's you pass in, and record, record2, record3, ... +# are the record hash refs mentioned above with the relationship requested (parents, +# children, siblings, etc.) +# +package GT::SQL::Tree; +# =============================================================== +use strict; +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::SQL::Table; +use GT::AutoLoader; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants + TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + $self->{connect} = $self->{table}->{connect}; + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + my $tree_table = $self->{table}->name . "_tree"; # ->name returns the table _prefixed_ + my $name = $self->{connect}->{def_path} . '/' . $tree_table . '.def'; + -e $name or return $self->error(FILENOEXISTS => FATAL => $name); + + $tree_table = $self->new_table($tree_table); + + $self->{tree} = $tree_table; + + return $self; +} + +sub DESTROY {} + +$COMPILE{create} = __LINE__ . <<'END_OF_SUB'; +sub create { +# ----------------------------------------------------------- +# GT::SQL::Tree->create(...) +# Create a new table, $tablename . "_tree". +# The arguments are as follows: +# table => $table_obj, # This is the table object the tree is to be built upon. +# father => 'father_id_fk', # The column in the table that contains the father ID. It must already exist. +# root => 'root_id_fk', # The column in the table that contains the root ID. It must already exist. +# depth => 'rec_depth', # The column in the table that keeps track of the depth (below the root) of the record. +# +# Optional arguments: +# force => 'force', # Specifies to argument to GT::SQL::Creator->create. Typically, 'force' or 'check'. +# debug => $debug_level, # Specifies to debug level for the GT::SQL::Tree object. +# rebuild => $rebuild, # A GT::SQL::Tree::Rebuild object +# You'll get back a GT::SQL::Tree object, just as if you had called new() for +# a tree that already existed. +# +# The new table created will have the following keys: +# tree_id_fk : A foreign key to the primary key of the table passed in +# tree_anc_id_fk : Also a foreign key to the primary key, this one stores an ancestor of id_fk +# tree_dist : This stores the distance (levels) between the ID and the ancestor. +# +# To give an example of how this will all look, let's say we have a structure like this: +# a +# - b +# - c +# - d +# - e +# Where b and c are children of a, d is a child of c, and e is a child of d. +# There will be the normal records, one per element. So, the main table looks +# like this: +# +# +-------+------+--------------+------------+-----------+ +# | pk_id | name | father_id_fk | root_id_fk | rec_depth | +# +-------+------+--------------+------------+-----------+ +# | 1 | a | 0 | 0 | 0 | +# | 2 | b | 1 | 1 | 1 | +# | 3 | c | 1 | 1 | 1 | +# | 4 | d | 3 | 1 | 2 | +# | 5 | e | 4 | 1 | 3 | +# +-------+------+--------------+------------+-----------+ +# +# For this example, the associated tree table will look like this: +# +# +------------+----------------+-----------+ +# | tree_id_fk | tree_anc_id_fk | tree_dist | +# +------------+----------------+-----------+ +# | 2 | 1 | 1 | +# | 3 | 1 | 1 | +# | 4 | 3 | 1 | +# | 4 | 1 | 2 | +# | 5 | 4 | 1 | +# | 5 | 3 | 2 | +# | 5 | 1 | 3 | +# +------------+----------------+-----------+ +# +# This format allows GT::SQL::Tree to easily (one simply query) select all +# descendants or ancestors given an ID. +# +# Calling ->create() on a table with data may take quite some time as it will +# create a tree for that table. You can, however, use this to recreate the +# tree for a particular table. +# + my $class = shift; + my $input = $class->common_param(@_) or return $class->error(BADARGS => FATAL => 'GT::SQL::Tree->create(HASH or HASH REF)'); + + my $self = {}; + + bless $self, ref $class || $class; + $self->{_debug} = $input->{debug} if $input->{debug}; + + my $table = $input->{table}; + $table and $table->name or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., table => $table_obj, ...)'); + $input->{father} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., father => \'father_col\', ...)'); + $input->{root} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., depth => \'depth_col\', ...)'); + + $self->{connect} = $table->{connect}; + + $table->pk and @{$table->pk} == 1 or return $self->error(TREEBADPK => FATAL => $table->name); + + # If a rebuild object was passed in, let it do its stuff. + if ($input->{rebuild}) { + $input->{rebuild}->_rebuild($table->pk->[0], @$input{qw/root father depth/}); + } + + my $tree = $table->name . "_tree"; + + my $c = $self->creator($tree); + + $c->cols([ + tree_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'ID' }, + tree_anc_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Ancestor' }, + tree_dist => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Distance' } + ]); + + my $table_name = $table->name(); + $table_name =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $pk = $table->pk()->[0]; + $c->fk({ + $table_name => { tree_id_fk => $pk, tree_anc_id_fk => $pk } + }); + + $c->subclass({ + relation => { "${table_name}\0${table_name}_tree" => 'GT::SQL::Tree::Relation' } + }); + + my $tree_i_prefix = lc substr($table_name, 0, 4); + + $c->index({ + "${tree_i_prefix}_tri" => ['tree_id_fk'], + "${tree_i_prefix}_tra" => ['tree_anc_id_fk', 'tree_dist'] + }); + + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_ROOT] = $input->{root}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_FATHER] = $input->{father}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_DEPTH] = $input->{depth}; + + $self->debug("Creating tree table '$tree'") if $self->{_debug}; + my $ok = $c->create($input->{force} || 'force'); + + if (!$ok) { + if ($GT::SQL::errcode eq 'TBLEXISTS') { + $c->set_defaults(); + $c->save_schema(); + } + else { + return; + } + } + + $table->fk($table_name => { $input->{father} => $pk }); + + $table->{schema}->{tree} = 1; + $self->debug("Saving tree existance in parent schema") if $self->{_debug}; + $table->save_state(); + $self->{table} = $table; + $self->{tree} = $self->new_table($tree); + + return $self unless $ok and $table->count(); # $ok will be false if we were instructed NOT to overwrite the table + + # Uh oh, this is fun... it means we have to create the tree from the existing table. + $self->debug("$table_name already has rows; building new tree table data") if $self->{_debug}; + $self->{tree}->delete_all(); + + my ($root_col, $depth_col, $father_col) = ($self->root_id_col, $self->depth_col, $self->father_id_col); + + my $top = $table->select("MAX($pk)")->fetchrow; + my $count = $table->count(); + my $roots = $table->count($root_col => 0); + $self->debug("Building ancestor tree ...") if $self->{_debug}; + my ($j, %parents, %depth); # %parent = ( id => [parents], id => [parents], ... ), %depth = ( $id => $depth, $id => $depth, ... ) + + for (my $i = 0; $i < $top; $i += 500) { # Get 500 threads at a time + $table->select_options("ORDER BY $root_col, $depth_col"); + my $cond = GT::SQL::Condition->new($root_col => '>' => $i, $root_col => '<=' => $i + 500); + + my $sth = $table->select($pk, $root_col, $father_col, $depth_col => $cond); + + my $last_root = 0; + %parents = (); + while (my ($id, $root, $parent, $depth) = $sth->fetchrow) { + if ($parent == $root) { + $parents{$id} = [$parent]; + } + else { + $parents{$id} = [@{$parents{$parent} || []}, $parent]; + } + $depth{$id} = $depth; + $self->debug("Processed $j records...") if $self->{_debug} and (++$j % 5000) == 0; + } + my @inserts; + if (keys %parents) { + for my $id (keys %parents) { + for my $anc (@{$parents{$id}}) { + push @inserts, [$id, $anc, $depth{$id} - ($depth{$anc} || 0)]; + } + } + } + + $self->{tree}->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @inserts) if @inserts; + } + + $self->debug("$j non-root nodes found.") if $self->{_debug}; + + return $self; +} +END_OF_SUB + +$COMPILE{destroy} = __LINE__ . <<'END_OF_SUB'; +sub destroy { +# ----------------------------------------------------------- +# $obj->destroy +# Drops the tree for the table of the current object. + + my $self = shift; + my $c = $self->creator($self->{table}->name . "_tree"); + + $c->drop_table; + + delete $self->{table}->{schema}->{tree}; + $self->{table}->save_state(); + + return 1; +} +END_OF_SUB + +sub root_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_ROOT]; +} + +sub father_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_FATHER]; +} + +sub depth_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_DEPTH]; +} + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $tree->insert(insert_id => $inserted_id, data => $insert_hash); +# This will insert the approriate record into the tree table. +# $inserted_id should be the insert_id of the new record and +# $insert_hash should contain at least the father, root, and +# depth columns. +# The number of rows inserted into the tree table is returned +# on success. Note that 0 is returned as 0e0 for a root. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->insert(HASH or HASH_REF)'); + + my $table = $self->{tree} or return $self->error(NOTREEOBJ => FATAL => '$tree->insert()'); + + my $insert_id = $input->{insert_id}; + my $data = $input->{data}; + + my $f = $self->father_id_col; + + return "0e0" unless my $fid = $data->{$f}; # If there is no father, it's a root, so we don't do anything. + + my $parents = $self->parents(id => $fid); + + push @$parents, { tree_id_fk => $fid, tree_anc_id_fk => $fid, tree_dist => 0 }; # tree_id_fk isn't used, and dist will have one added to it to get the node-father row + + my @insertions; + for (@$parents) { + my ($anc, $depth) = @$_{'tree_anc_id_fk', 'tree_dist'}; + + push @insertions, [$insert_id, $anc, $depth + 1]; + } + $table->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @insertions); + + return scalar @insertions; +} +END_OF_SUB + +$COMPILE{pre_update} = __LINE__ . <<'END_OF_SUB'; +sub pre_update { +# ----------------------------------------------------------------------------- +# $tree->update(where => $condition, data => $update_hash); +# $update_hash should contain the father_id column. This should only be +# called (by GT::SQL::Table) when an update occurs that changes the +# father_id. $update_hash must be the hash reference that will be used for +# the update because it is going to be changed for the root and depth fields. +# You're going to get back some sort of data structure from this (subject to +# change). Pass the data structure into "update" after the update occurs +# successfully. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->update(HASH or HASH REF)'); + + my $update_hash = $input->{data} or return $self->error(BADARGS => FATAL => '$tree->update(... data => $update_hash ...)'); + + my $where = $input->{where} or return $self->error(BADARGS => FATAL => '$tree->update(... where => $condition ...)'); + + my ($pk, $r, $f, $d) = ($self->{table}->pk()->[0], $self->root_id_col, $self->father_id_col, $self->depth_col); + + my $new_father = $input->{data}->{$f}; + my ($table, $tree) = ($self->{table}, $self->{tree}); + my %ids = $self->{table}->select($pk, $d => $where)->fetchall_list; + if ($new_father and exists $ids{$new_father}) { + # Cannot update a row to be a child of itself + return $self->error(TREEFATHER => 'WARN'); + } + # keys %ids are the ID's of the records being moved. The values are the depth BEFORE moving. + my $old_parents = $self->parent_ids(id => [keys %ids]); + my $children = $self->child_ids(id => [keys %ids], include_dist => 1); + + my $delete_cond; + for my $parent (keys %ids) { + my @p = @{$old_parents->{$parent}}; + my @c = keys %{$children->{$parent}}; + for (@c) { + if ($_ == $new_father) { + # We can't update a row to be a child of it's children + return $self->error(TREEFATHER => 'WARN'); + } + } + + next unless @p; # If there aren't any old parents, this record already is a root and isn't changing. + + $delete_cond ||= GT::SQL::Condition->new('OR'); + + $delete_cond->add( + GT::SQL::Condition->new( + tree_anc_id_fk => IN => \@p, + tree_id_fk => IN => [$parent, keys %{$children->{$parent}}] + ) + ); + } + + my ($new_depth, $new_root_id, $update, @insert) = (0, 0); + if ($new_father) { + my %new_parents = ($new_father => 0, %{$self->parent_ids(id => $new_father, include_dist => 1)}); + my %insert_seen; + for my $new (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + for my $new_child ($new, keys %{$children->{$new}}) { + next if $insert_seen{$new_child}++; # If it's already seen, it means it's already been handled. This can occur when moving both a child and parent to be children of a new node - the child will be a sibling of its old parent + for my $new_anc (keys %new_parents) { + my $child_dist = $new_child == $new ? 0 : $children->{$new}->{$new_child}; + push @insert, [$new_anc, $new_child, $new_parents{$new_anc} + 1 + $child_dist] unless $insert_seen{"$new_anc\0$new_child"}++; + } + } + } + + ($new_depth, $new_root_id) = $self->{table}->select($d, $r => { $pk => $new_father })->fetchrow; + $new_root_id ||= $new_father; + $new_depth++; + + my %seen; + push @$update, { set => { $r => $new_root_id }, where => { $pk => [grep !$seen{$_}++, keys %ids, map { keys %{$children->{$_}} } keys %$children] } }; + } + else { + $update_hash->{$r} = 0; + my %seen; + for (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + push @$update, { set => { $r => $_ }, where => { $pk => [grep !$seen{$_}++, keys %{$children->{$_}}] } }; + } + } + + my ($delta, %updates, %seen); + for my $parent (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + $delta = $new_depth - $ids{$parent}; + next if !$delta or $seen{$parent}++; + push @{$updates{$delta}}, $parent; + for (keys %{$children->{$parent}}) { + unless ($seen{$_}++) { + $self->debug("Adjusting depth of $_ by $delta") if $self->{_debug}; + push @{$updates{$delta}}, $_; + } + } + } + + for my $delta (keys %updates) { + push @$update, { set => { $d => \"$d + $delta" }, where => { $pk => $updates{$delta} } }; + } + + return { delete => $delete_cond, insert_multiple => [[qw/tree_anc_id_fk tree_id_fk tree_dist/], @insert], update => $update }; +} +END_OF_SUB + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# --------------------------------------------------------- +# This basically executes whatever is decided above. pre_update +# is where everything important is decided. + my $self = shift; + my $input = shift; # This should be whatever pre_update returned. + if ($input->{delete}) { + $self->debug("Deleting now-invalid tree records") if $self->{_debug} >= 1; + $self->{tree}->delete($input->{delete}); + } + if ($input->{insert_multiple} and @{$input->{insert_multiple}} >= 2) { + $self->debug("Inserting new tree records required") if $self->{_debug} >= 1; + $self->{tree}->insert_multiple(@{$input->{insert_multiple}}); + } + if ($input->{update}) { + $self->debug("Updating tree depths required after an update") if $self->{_debug} >= 1; + for (@{$input->{update}}) { + $self->{table}->update($_->{set}, $_->{where}); + } + } +} +END_OF_SUB + +sub children { +# ----------------------------------------------------------- +# $tree->children(id => [$pkval1, $pkval2, ...], max_depth => $max_depth) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->children(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if defined $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->children()'); + for (@$ids) { + $ids = 0 if not $_; + } + + my $parent = $self->{table}->name(); + my $tree = $self->{tree}->name(); + my $roots_only = $input->{roots_only}; + $roots_only = 1 if not $ids; + my ($select_from, $left_join); + if ($roots_only and ref $input->{select_from}) { + $select_from = $input->{select_from}; + $left_join = $input->{left_join}; + } + elsif ($ids and !$roots_only) { + $select_from = $self->{table}->new_relation($parent, $tree); + } + else { + $select_from = $self->{table}; + } + + my $max_depth = $input->{max_depth}; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my $pk = $self->{table}->pk()->[0]; + my $cond; + + my $sort_col = $input->{sort_col} || []; + my $sort_order = $input->{sort_order} || []; + $sort_col = [$sort_col] if $sort_col and not ref $sort_col; + $sort_order = [$sort_order] if $sort_order and not ref $sort_order; + my $sort_col_saved = [@$sort_col]; + my $order_by; + if ($sort_col) { + if (@$sort_order) { + for (0 .. $#$sort_col) { + last if $_ > $#$sort_order; + $sort_col->[$_] .= " $sort_order->[$_]" if $sort_order->[$_]; + } + } + $order_by = "ORDER BY " . join ", ", @$sort_col if @$sort_col; + } + + if ($input->{condition} and UNIVERSAL::isa($input->{condition}, 'GT::SQL::Condition')) { + $cond = new GT::SQL::Condition; + $cond->add($input->{condition}); + } + my %roots_order; # We might need this, if using the roots_order_by option. + if ($ids) { + $cond ||= new GT::SQL::Condition; + if ($roots_only) { + $cond->add("$parent.$root_col" => IN => $ids); + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + else { + $cond->add("$tree.tree_anc_id_fk" => IN => $ids); + $cond->add("$tree.tree_dist" => '<=' => $max_depth) if $max_depth; + } + } + else { + if ($roots_only and $input->{limit}) { + # The following only applies when a limit is being used - otherwise, everything will be returned. + my $c = new GT::SQL::Condition; + $c->add($cond) if $cond; + $c->add($root_col => '=' => 0); + + if ($input->{roots_order_by}) { + $self->{table}->select_options('ORDER BY ' . $input->{roots_order_by}); + } + else { + $self->{table}->select_options($order_by); + } + $self->{table}->select_options("LIMIT $input->{limit}"); + + my @roots = $self->{table}->select($pk => $c)->fetchall_list; + if ($input->{roots_order_by}) { + my $r; + %roots_order = map { ($_ => $r++) } @roots; + } + my @children = $self->{table}->select($pk => { $root_col => \@roots })->fetchall_list; + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$pk" => IN => [@roots, @children]); + } + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + + my $get_cols = $input->{cols}; + $get_cols = [$get_cols] if $get_cols and not ref $get_cols; + if ($get_cols) { + my ($found_root, $found_father, $found_depth, $found_anc); + for (@$get_cols) { + last if $found_root and $found_father and $found_depth; + $found_anc++ if not $found_anc and $_ eq 'tree_anc_id_fk'; + $found_root++ if not $found_root and $_ eq $root_col; + $found_depth++ if not $found_depth and $_ eq $depth_col; + $found_father++ if not $found_father and $_ eq $father_col; + } + push @$get_cols, $root_col if not $found_root; + push @$get_cols, $depth_col if not $found_depth; + push @$get_cols, $father_col if not $found_father; + push @$get_cols, 'tree_anc_id_fk' unless $found_anc or $roots_only; + push @$get_cols, 'tree_dist' unless $roots_only; + } + + $select_from->select_options($order_by) if $order_by; + my $sth = $select_from->select($left_join ? ('left_join') : (), $get_cols || (), $cond || ()); + + my $return = $self->_sort($sth, !$ids, $roots_only, (keys %roots_order ? \%roots_order : ())); + + if ($ids) { + for (@$ids) { + $return->{$_} ||= []; + } + } + return $ref ? $return : $return->{$ids ? $ids->[0] : 0}; +} + +sub _sort { +# ----------------------------------------------------------- +# Used internally. Sorts an array ref of hash refs into the +# proper order for a tree. + my ($self, $sth, $from_root, $roots_only, $rp) = @_; + my $pk = $self->{table}->pk()->[0]; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my (@recs, %children, %root_pos, $r); +# When we're done this first part, @recs and %children will look like: +# +# @recs = ( +# [$thread1_immediate_child1, $thread1_immediate_child2, ...], +# [$thread2_immediate_child1, $thread2_immediate_child2, ...], +# ... +# ); +# %children = ( +# $ancestor_id => { +# $child_level_1_rec_1_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# $child_level_1_rec_2_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# ... +# }, +# $ancestor_id => { ... }, +# ... +# ) +# +# Each element in @recs contains the immediate children of a requested base row +# (often a root, but not necessarily). Root positions are stored in %root_pos, +# so that all appropriate rows of a tree are grouped together. +# +# The $ancestor_id in %children is the requested ID. If requesting just roots, +# this is the root ID, otherwise it is the ancestor ID. +# +# To determine the final list, each element will have its children placed +# immediately after itself in a recursive-like way, though not implemented here +# with recursion. +# +# Also note that duplicates are possible, when a requested "root" is really a +# child/descendant of another requested root. + +# $anc_col is how a thread relates; typically this is the root_id, but isn't +# required to be when not using roots_only. + my $anc_col = $roots_only ? $root_col : 'tree_anc_id_fk'; + + while (my $rec = $sth->fetchrow_hashref) { + if (not exists $root_pos{$rec->{$anc_col} || $rec->{$pk}}) { # We haven't encountered this root yet. + $root_pos{$rec->{$anc_col} || $rec->{$pk}} = $from_root ? 0 : $r++; + } + if ($roots_only) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec + if $rec->{$anc_col}; + + push @{$recs[$root_pos{$rec->{$anc_col} || $rec->{$pk}}]}, $rec + if $rec->{$depth_col} == ($from_root ? 0 : 1); + } + else { + if ($rec->{tree_dist} > 1) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec; + } + else { + push @{$recs[$root_pos{$rec->{$anc_col}}]}, $rec; + } + } + } + + my @sorted; +# The goal here is to make @sorted look like this: +# @sorted = ( +# [$reply1, $reply2, ...], +# [$reply1, $reply2, ...], +# ... +# ); +# Each array ref corresponds to one tree. Note that $reply1 could be a root, not a reply :) + +# The mess below properly sorts out a thread, paying attention to both the +# parent and, if specified, sort_col and sort_order. + + # Go through all threads in @recs - each element is a thread + for my $thread (@recs) { + while (@$thread) { + my $this = shift @$thread; + if (my $children = $children{$this->{$anc_col} || $this->{$pk}}->{$this->{$pk}}) { + unshift @$thread, @$children; + } + my $sort_i = $root_pos{$this->{$anc_col} || $this->{$pk}}; + push @{$sorted[$sort_i]}, $this; + } + } + + if ($from_root and $rp) { # If $rp was passed in, order the array refs according to $rp->{$root_id} +# $sort[0] is sorted for all the elements. What we have to do now is group them into threads. + my $i; + my %cur_pos = map { ("$_" => $i++) } @{$sorted[0]}; + $sorted[0] = [ + sort { + ( # This bit sorts by root ID + $rp->{$a->{$anc_col} || $a->{$pk}} + <=> + $rp->{$b->{$anc_col} || $b->{$pk}} + ) + || + ($cur_pos{$a} <=> $cur_pos{$b}) # Keep the order for elements with the same root id + } + @{$sorted[0]} + ]; + } + + my $return = {}; + for my $tree (@sorted) { + my $root = $from_root ? 0 : $tree->[0]->{$anc_col}; + push @{$return->{$root}}, @$tree; + } + + $return; +} + +$COMPILE{parents} = __LINE__ . <<'END_OF_SUB'; +sub parents { +# ----------------------------------------------------------- +# $tree->parents(id => [$pkval1, $pkval2, ...]) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parents(HASH or HASH_REF)'); + + $self->{tree} and $self->{table} or return $self->error(NOTREEOBJ => FATAL => '$tree->parents()'); + + my $parent = $self->{table}->name(); + $parent =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $tree = $self->{tree}->name(); + $tree =~ s/^\Q$self->{connect}->{PREFIX}\E//; + + my $rel = $self->{table}->new_relation($parent, $tree); + + my $get = $input->{cols}; + $get = [] unless ref $get eq 'ARRAY'; + my $depth = $self->depth_col; + if (@$get) { # If $get is empty, everything will be returned. + my ($found_t, $found_d); + for (@$get) { + $found_t++ if $_ eq 'tree_id_fk'; + $found_d++ if $_ eq $depth; + last if $found_t and $found_d; + } + push @$get, 'tree_id_fk' if not $found_t; + push @$get, $depth if not $found_d; + } + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not $ref; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parents()'); + + $GT::SQL::Tree::Relation::Anc_Join = 1; + my $sth = $rel->select(@$get => { tree_id_fk => $ids }); + $GT::SQL::Tree::Relation::Anc_Join = 0; + + my $return = { map { ($_ => []) } @$ids }; + + while (my $rec = $sth->fetchrow_hashref) { + push @{$return->{$rec->{tree_id_fk}}}, $rec; + } + + for (@$ids) { + @{$return->{$_}} = sort { $a->{$depth} <=> $b->{$depth} } @{$return->{$_}}; + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{child_ids} = __LINE__ . <<'END_OF_SUB'; +sub child_ids { +# ----------------------------------------------------------- +# $tree->child_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing at least an 'id' key. +# The value of the 'id' key is an array reference of ancestor ID's whose +# descendants (children, children's children, etc.) you are looking for. +# max_depth can be specified to limit a maximum child depth to return. +# OUT: Depends on include_dist. +# Without include_dist: hash ref of array ref. There will be one key for +# each ID you pass in. If there are no children, the array ref value will +# contain no elements. Each array element is a child ID. +# With include_dist: hash ref of hash refs. One key for each ID you pass +# in. The inner hash refs have keys of the ID's and values of the +# distance between what you passed in and the element. Essentially, +# keys() of an include_dist hash is the same as the array ref without +# include depth. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->child_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->child_ids()'); + + my @get = qw/tree_anc_id_fk tree_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_anc_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($anc, $id, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$anc}->{$id} = $dist; + } + else { + push @{$return->{$anc}}, $id; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{parent_ids} = __LINE__ . <<'END_OF_SUB'; +sub parent_ids { +# ----------------------------------------------------------- +# $tree->parent_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing an 'id' key. +# The value of the 'id' key is an array reference of children ID's whose +# ancestors (parents, parents' parents, etc.) you are looking for. +# OUT: hash ref of array refs. There will be one key for each ID you pass in. +# Each array ref contains the ID's of the parents. +# Liks child_ids, the return is different if you pass in "include_dist". +# See child_ids for a description. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parent_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parent_ids()'); + + my @get = qw/tree_id_fk tree_anc_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($id, $anc, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$id}->{$anc} = $dist; + } + else { + push @{$return->{$id}}, $anc; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{num_children} = __LINE__ . <<'END_OF_SUB'; +sub num_children { +# ----------------------------------------------------------------------------- +# $tree->num_children([$pkval1, $pkval2, ...]) +# IN : A list or array reference of of parents ID's whose child counts +# you are looking for. +# OUT: Hash reference of ID => NUM_CHILDREN pairs. Note that this is the +# number of children (i.e. depth = 1), not descendants. +# + my $self = shift; + + my @ids = map { + ref eq 'ARRAY' + ? @$_ + : ref() + ? $self->error(BADARGS => FATAL => '$tree->num_children(ARRAY or ARRAYREF)') + : $_ + } @_; + + @ids or return $self->error(TREENOIDS => FATAL => '$tree->num_children()'); + + $self->{tree}->select_options('GROUP BY tree_anc_id_fk'); + my %return = $self->{tree}->select(tree_anc_id_fk => 'COUNT(*)', { tree_anc_id_fk => \@ids, tree_dist => 1 })->fetchall_list; + + for (@ids) { $return{$_} ||= 0 } + + return \%return; +} +END_OF_SUB + + +package GT::SQL::Tree::Relation; +# This is here to subclass the table->tree relation so that selects work properly + +use GT::SQL::Relation; +use vars qw/@ISA $ERROR_MESSAGE $Anc_Join/; # $Anc_Join is set by the tree module when the join should be on tree_anc_id_fk rather than tree_id_fk +@ISA = $ERROR_MESSAGE = 'GT::SQL::Relation'; + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + if (@$relations != 2) { + return $self->error(TREEBADJOIN => FATAL => "@$relations"); + } + my ($table, $tree) = @$relations; + ($table, $tree) = ($tree, $table) if !$relations->[0]->{schema}->{tree}; + + return "$tree->{name}." . ($Anc_Join ? 'tree_anc_id_fk' : 'tree_id_fk') . " = $table->{name}." . $table->pk()->[0]; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree - Helps create and manage a tree in an SQL database. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + + my $tree = $table->tree; + my $children = $tree->children(id => [1,2,3], max_depth => 2); + + my $parents = $tree->parents(id => [4,5,6]); + +=head1 DESCRIPTION + +GT::SQL::Tree is designed to implement a tree structure with a SQL table. Most +of the work on managing the table is performed automatically behind the scenes, +however there are a couple of front end methods to retrieving the tree nodes +from a GT::SQL::Tree object. + +=head1 METHODS + +=head2 new, tree + +Typically, the way to get a tree object is to call ->tree on a table object. The +table object then calls GT::SQL::Tree->new for you and returns the results, +which is a GT::SQL::Tree object. Typically you should not call ->new directly, +but instead let $table->tree call it with the proper arguments. + +=head2 create, add_tree + +To use GT::SQL::Tree, you need to first call create(). You shouldn't call it +directly, but instead call ->add_tree() on an editor object. The arguments to +add_tree are passed through to create, so that they are essentially the same +(there is one exception - add_tree passed in C $table_object>). + +create() will create a tree table, with the name passed on the name of the table +passed in. For example, if you wish to build a tree on 'MyTable', the tree table +that is created by create() will be named MyTable_tree. The tree table provides +easy one-query access to all of a nodes parents or children, and also keeps +track of the number of hops between a node and its descendant, allowing you to +limit how far you descend into the tree. + +The following arguments are required: + +=over 4 + +=item table + +This contains the table object for the table the tree is to be built upon. Note +that when calling add_tree you B specify this - add_tree passes it +along on its own. + +=item father + +This must specify the name of the father ID column. The father ID column +controls the relationship between father/child. + +For example, if your primary key is "my_id" and your father id column is +"my_father_id", you would pass in "my_father_id" as the value to C. + +=item root + +This is used to specify the name of the root column. For example, if your +primary key is "my_id" and your root id column is "my_root_id", you would pass +in "my_root_id" as the value to C. + +=item depth + +This is used to specify the name of the depth column for the table. For example, +if you are using a column named "my_depth" to keep track of the depth of a node, +you would pass in "my_depth" as the value to C. + +=back + +The following are optional arguments to create/add_tree: + +=over 4 + +=item force + +Takes a value such as 'force' or 'check'. This value is passed on to the +GT::SQL table creation subroutine. + +=item rebuild + +You can pass in a GT::SQL::Tree::Rebuild object if you have an incomplete or +invalid table structure. See L for more details. + +=item debug + +Sets the debug level of the tree object. add_tree() automatically passes in the +debug value for the table object, so it normally is not necessary to set this. + +=back + +=head2 destroy, drop_tree + +You can call C<$tree-Edestroy> to destroy a tree. This involves dropping the +tree table and deleting the tree reference from the table the tree was on. This +can be called by calling C<$tree-Edestroy()> on a GT::SQL::Tree object, +however this is typically invoked by calling C<$editor-Edrop_tree()> on a +table editor object. + +Neither C<$tree-Edestroy()> nor C<$editor-Edrop_tree()> take any +arguments. + +=head2 root_id_col, father_id_co, depth_col + +These three tree object methods return the name of the associated column in the +main table. Usually you will already know them, and these methods are primarily +used internally. + +=head2 children + +This is where the usefulness of the tree module comes into play. +C<$tree-Echildren> is used to access all of the children of a particular +node. It takes a wide variety of arguments to control the return. + +Usually, the return will be either a hash reference of array references each +containing hash references, or else an array reference of hash references. Which +reference you get depends on what you request via the C parameter, described +below. Each inner hash reference is a row from the database, typically a joined +row from the table the tree is on with the tree table, however the +C, C, and C parameters all change this behaviour. + +The arguments to C are as follows: + +=over 4 + +=item id + +The value of the id key is either a scalar value, or an array reference. The +value/values to id should be the id whose descendants you are looking for. For +example, if you are looking for the children of ID 3 and ID 4, you would pass in +C [3, 4]>. The return value of children will be a hash reference +containing two keys: 3 and 4. + +If you are looking for the children of a single ID and pass the id as a scalar +value, you will get back an array reference as described above. + +So, basically, if the value to id is an array reference, you will get back a +hash reference of array references of hash references; if it is a scalar value, +you will get back an array reference of hash references. + $tree->children(id => [1])->{1}; +and + $tree->children(id => 1); +will result in the same thing. + +To get all the trees in a single query, you pass in 0 as the value. This is as +if you are requesting the children of the imaginary root to which all roots +belong. + +C is the only required parameter. + +=item max_depth + +You can specify a max_depth value to specify that the records returned should +not be more a certain distance from the node. For example, supposing you have +this tree: + a + b + c + d +Selecting the children of a with a max_depth of 1 would return just b, not c or +d. A max_depth of 2 would return b and c. + +Not specifying max_depth means that you do not want to limit the maximum +distance from the parent of the returned values. + +=item cols + +You can specify an array reference as the value to C to alter the values +returned. Instead of doing "SELECT * FROM ...", the query will be "SELECT FROM ...". Note, however, that the father, root, and depth columns +are required and will be present in the rows returned whether or not you specify +them. + +=item sort_col, sort_order + +Where the C option sorts the results based on tree levels, C and +C control the sorting for nodes with the same father ID. For +example, with this tree: + a + b + c +C and C affect whether or not b comes before or after c. +The value of each can either be a scalar value or an array reference. There is +essentially no difference, the scalar value is just a little easier when you are +only sorting on a single column. The values of C should be column +names, and the values of C 'ASC' or 'DESC', per sort column +respectively. For example: + sort_col => ['a','b'], sort_order => ['ASC', 'DESC'] +will sort first in ascending order based on the value of a, then descending +order based on the value of column b. This correlates directly to SQL - it +becomes "ORDER BY a ASC, b DESC". + +You can specify a different sort order for roots by using the C +option, when using C 0>. See below. + +=item condition + +If you want to limit the results, you can pass a GT::SQL::Condition object into +C via the condition key. The condition will apply to the select +performed. For example, if you want to select rows with a column "a" having a +value less than 20, you could do: + my $cond = GT::SQL::Condition->new(a => '<' => 20) + my $children = $tree->children(..., condition => $cond); + +=item limit + +Like condition, you can specify any valid LIMIT _____ value here, for example +"50, 25". This option is only used when using C 0> - it will limit the +number of roots returned, taking into account the sort_col and sort_order. + +=item roots_only + +If you specify this option, it will assume that what you passed in via C +consists only of root_ids. Doing so makes a join with the tree table +unneccessary and allows you to use the C option. This option can be +used (and generally this is a good idea) when specifying C 0>. + +=item roots_order_by + +This option controlls the order of root posts, when selecting roots using +C 0> and a limit. C above will affect the order of +children of the roots, but the order of the roots themselves will be controlled +by whatever C value you specify here. + +Again, this option requires that C 0>, C, and C are +also being used. + +If this option is omitted, the C will be generated from the values of +the C and C options. + +=item select_from + +If you are using roots_only, you can also specify the C option. +This option allows you to perform the selects from a GT::SQL::Relation object +instead of just the table associated with the tree. Note that the table +associated with the tree must be part of the relation, however you can have as +many other tables as you like. + +=item left_join + +If the select_from relation should be a left join, pass C 1>. +This simply passes the C option to ->select. This option is only +applicable when select_from is used. + +=back + +=head2 parents + +This is effectively the opposite of children. Instead of getting back all of the +children nodes, it gives the parents, all the way up to the root for any given +node. The return value is the same as that of C, so see that section. + +Each array returned by C is sorted by depth from root to parent. + +=over 4 + +=item id + +C is the only required parameter for C. It should be either a +scalar value or an array reference. You specify the ID's of children whose +parents you are looking for. The type of argument (scalar or array ref) affects +the return in the same way as C. + +=item cols + +C works in a similar way to the C parameter to C. You +specify the columns you want in the return as an array ref. What you get back +will have these columns in it. If C is not specified, you'll get back all +columns. + +Note that 'tree_id_fk' and the depth column for the table are required fields +and will be added if not specified. + +=back + +=head2 child_ids + +If you are looking for just the ID's of the children of a particular node, you +should use this. The return value is one of the following, depending on what you +pass in: + +hash reference of array references: + { ID => [ID, ID, ...], ... } +with one ID in the hash reference for each id you specify. The array reference +contains the child ID's of the key ID. + +hash reference of hash references: + { ID => { ID => dist, ID => dist, ... }, ... } +with one ID in the other hash reference for each id you specify. The inner hash +reference is made of child_id => child_distance key-value pairs. + +array reference or hash reference: + [ID, ID, ...] +hash reference: + { ID => dist, ID => dist } + +The first two apply when passing in an array reference for C, the latter two +when passing a scalar value for C. The first and third are without +C specified, the second and fourth occur when you specify +C. + +=over 4 + +=item id + +Like all other accessors, child_ids takes a scalar value or array reference as +the C value. Return as noted above. + +=item include_dist + +This changes the return as noted above - instead of just getting an array +reference of child ID's, you get the child ID's as the keys of a hash reference, +and the distances of the child from the parent you requested as the values. + +=back + +=head2 parent_ids + +Exactly the same as child_ids, except that this works I the tree instead of +I. Takes the same arguments, gives the same possible returns. + +=head1 INDICES + +A tree requires a few indices to get optimal performance out of it. If the table +is never expected to be more than just a few rows, you won't notice a +substantial difference, however, as with any table, as the table grows the +performance proper indexing provides becomes more appreciable. + +Two indices are created automatically on the tree table, one on tree_id_fk, and +the other on tree_anc_id_fk,tree_dist, so you don't need to worry about that +table. + +Obviously, the usage of the tree affects how many indices you want, this section +is simply to provide some general guidelines for the indices required. + +Because the roots_only option is based solely on the main table and not the +tree, if you are using roots_only (calling children with id => 0 automatically +turns on the roots_only option), you want to make sure you have an index on the +root column. If you also use the max_depth depth option, add the depth column to +this index. + +Keep in mind that you may need to mix other columns in here if you are using a +condition with children(). This also applies when using the C and +C parameters - basically you need to figure out what your indices +are, and then add in the root column and, if using max_depth, the depth column. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Tree.pm,v 1.30 2008/06/11 06:55:26 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree/Rebuild.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree/Rebuild.pm new file mode 100644 index 0000000..4ad07a4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Tree/Rebuild.pm @@ -0,0 +1,237 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# This goes hand in hand with GT::SQL::Tree and is very useful in +# turning an existing table without the root, and/or depth columns +# into a GT::SQL::Tree-compatible format. +# +package GT::SQL::Tree::Rebuild; +# =============================================================== +use strict; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +# New returns a GT::SQL::Tree::Rebuild object when you can pass to GT::SQL::Tree. +# When you are adding a tree to an existing table, but the table does not have +# the root and/or depth columns, you get a Rebuild object, then pass it to +# ->add_tree so that your tree can be built anyway. +# You need to call new with the following options: +# table => $Table_object +# missing_root => sub { ... }, # Only if you are missing the root. The code reference should return the pk of the root. +# missing_depth => 1, # Only if you are missing the depth. The code reference should return the depth of the node. +# missing_father => 1, # Only if you are missing the father. The code reference should return the pk of the father. +# cols => [...], # The columns you want %row (discussed below) to contain +# +# The code references are passed two arguments: +# \%row, # A row from the table. If using the cols option, it will only have those columns. +# $table_object, # This is the same object you pass to new() +# \%all # This is a hash reference of all rows; each key is a primary key, each value the row. This may or may not be of use to you. +# +# For depth, %all will have root and father ids set, for roots father ID's will be set. +# +# NOTE: The father, root, and depth columns must exist beforehand. +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new(HASH or HASH REF)'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ ... table => $table_obj ... })'); + for (qw(missing_root missing_depth missing_father)) { + next unless exists $opts->{$_}; + $self->{$_} = $opts->{$_}; + ref $self->{$_} eq 'CODE' or return $self->error(BADARGS => FATAL => '$obj->new({ ... ' . $_ . ' => sub { ... } ... })'); + } + $self->{cols} = $opts->{cols} if $opts->{cols}; + $self->{cols} = [$self->{cols}] if $self->{cols} and not ref $self->{cols}; + $self->{cols} ||= []; + $self->{order_by} = $opts->{order_by} if $opts->{order_by}; + + $self->{missing_root} or $self->{missing_depth} or $self->{missing_father} or return $self->error(BADARGS => FATAL => 'At least one of "missing_root", "missing_depth", or "missing_father" must be passed to $obj->new({ ... })'); + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + $self; +} + +# Called internally by the GT::SQL::Tree object. This does all the calculations. +# Note that this only rebuilds the table itself, GT::SQL::Tree->create will still +# have to create its tree table. +sub _rebuild { + my ($self, $pk, $root_col, $father_col, $depth_col) = @_; + my $table = $self->{table}; + + my $count = $table->count(); + for (my $i = 0; $i < $count; $i += 10000) { + $table->select_options("ORDER BY $self->{order_by}") if exists $self->{order_by}; + $table->select_options("LIMIT 10000" . ($i ? " OFFSET $i" : "")); + my $sth = $table->select(@{$self->{cols}}); + while (my $row = $sth->fetchrow_hashref) { + my %update; + if ($self->{missing_father}) { + my $father_id = $self->{missing_father}->($row, $table); + $update{$father_col} = $father_id unless $row->{$father_col} == $father_id; + $row->{$father_col} = $father_id; + } + if ($self->{missing_root}) { + my $root_id = $self->{missing_root}->($row, $table); + $update{$root_col} = $root_id unless $row->{$root_col} == $root_id; + $row->{$root_col} = $root_id; + } + if ($self->{missing_depth}) { + my $depth = $self->{missing_depth}->($row, $table); + $update{$depth_col} = $depth unless $row->{$depth_col} == $depth; + $row->{$depth_col} = $depth; + } + + $table->update(\%update, { $pk => $row->{$pk} }) if keys %update; # If the new value(s) is/are 0, like the default value(s), %update will be empty + } + } + + return 1; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + use GT::SQL::Tree::Rebuild; + + my $rebuild = GT::SQL::Tree::Rebuild->new( + table => $DB->table('MyTable'), + missing_root => \&root_code, + missing_father => \&father_code, + missing_depth => \&depth_code, + order_by => 'column_name' + ); + + $DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild); + +=head1 DESCRIPTION + +GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and +aids in turning an existing table into one with the neccessary root, father and +depth columns needed by GT::SQL::Tree. + +The main purpose is to do a one-shot conversion of a table to make it compatible +with GT::SQL::Tree. + +=head2 new - Create a Rebuild object + +There is only one method that is called - new. You pass the arguments needed +and get back a GT::SQL::Tree::Rebuild object. This object should then be passed +into GT::SQL::Tree->create (typically via C<$editor-Eadd_tree()>) + +new() takes a hash with up to 4 argument pairs: "table" (required), and one or +more of "missing_root", "missing_father", or "missing_depth". The values are +explained below. + +=over 4 + +=item table + +Required. You specify the table object for the table to rebuild. For example, if +you are going to add a tree to the "Category" table, you provide the "Category" +table object here. + +=item cols + +By default, an entire row will be returned. To speed up the process and lower +the memory usage, you can use the C option, which specifies the columns to +select for $row. It is recommended that you only select columns that you need as +doing so will definately save time and memory. + +=item missing_father, missing_root, missing_depth + +Each of these arguments takes a code reference as its value. The arguments to +the code references are as follows: + +=over 4 + +=item $row + +The first argument is a hash reference of the row being examined. Your job, in +the code reference, is to examine $row and determine the missing value, +depending on which code reference is being called. missing_root needs to return +the root_id for this row; missing_father needs to return the father_id, and the +missing_depth code reference should return the depth for the row. + +=item $table + +The second argument passed to the code references is the same table object that +you pass into new(), which you can select from if neccessary. + +=back + +=item missing_father + +The C code reference is called first - before C +and C. The code reference is called as described above and should +return the ID of the father of the row passed in. A false return (0 or undef) is +interpreted as meaning that this is a root and therefore has no father. + +=item missing_root + +C has to return the root of the row passed in. This is called +after C, so the $row will contain whatever you returned in +C in the father ID column. Of course, this only applies if using +both C and C. + +=item missing_depth + +C has to return the depth of the row passed in. This is called +last, so if you are also using C and/or C, you +will have whatever was returned by those code refs available in the $row. + +=item order_by + +The query done to retrieve records can be sorted using the C option. +It should be anything valid for "ORDER BY _____". Often it can be useful to have +your results returned in a certain order - for example: + order_by => 'depth_column ASC' +would insure that parents come before roots. Of course, this example wouldn't +work if you are using "missing_depth" since none of the depth values will be +set. + +=back + +Once you have a GT::SQL::Tree::Rebuild object, you should pass it into +Ccreate> (which typically involves passing it into +C<$editor-Eadd_tree()>, which passed it through). Before calculating the +tree, GT::SQL::Tree will call on the rebuild object to reproduce the father, +root, and/or depth columns (whichever you specified). + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Types.pm b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Types.pm new file mode 100644 index 0000000..605c7df --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/SQL/Types.pm @@ -0,0 +1,384 @@ +1; + +__END__ + +=head1 NAME + +GT::SQL::Driver::Types - Column types supported by GT::SQL + +=head1 SYNOPSIS + + my $c = $DB->creator('new_table'); + $c->cols({ + column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 } + # ... more columns ... + }); + + my $e = $DB->editor('table_name'); + $e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' }); + +=head1 DESCRIPTION + +This module should not be used directly, however the documentation here +describes the different types support by GT::SQL and any caveats associated +with those types. + +=head1 ATTRIBUTES + +All types are specified as a C { column definition }> pair, +where the column definition should contain at least a C key containing +one of the L outlined below. Commonly accepted attributes are: + +=over 4 + +=item not_null + +Used to specify that a column should not be allowed to contain NULL values. +Note that for character/string data types, a 0-character string (and, for +C/C columns, strings containing only spaces), B considered +NULL values are are not permitted if the column is specified as C. +The value passed to not_null should be true. + +=item default + +Used to specify a default value to be used for the column when no explicit +value is provided when a row is inserted. The default value is also used for +the value in existing rows when adding a not_null column to an existing table - +in such a case, the C is B. + +Also see the L|/TEXT> section regarding caveats and limitations of +using C's for C types. + +=back + +Other column attributes are supported as outlined below. In addition to +attributes mentioned in this document, various attributes are available that +influence automatically-generated forms displayed by GT::SQL::Admin - see +L for details on these attributes. + +=head1 TYPES + +=head2 Integer types + +=over 4 + +=item TINYINT + +The C type specifies an 8-bit integer able to handle values from -128 +to 127. Some databases will allow larger values due to not supporting an +appropriate data type. The C column attribute I turn this into +an unsigned value supporting values from 0 to 255; due to this type being +implemented as a larger integer type in some databases (which, incidentally, +coincide with the databases not supporting an unsigned 8-bit C) using +an C TINYINT type will result in a column able to store any value +from 0-255, unlike most of the larger integer types below. + +=item SMALLINT + +The C type specifies a 16-bit integer able to handle values from +-32768 to 32767. The C column attribute I turn this into an +unsigned value supporting values from 0 to 65535, however this is B +guaranteed. If you need to store values in the 32768-65535 range, a larger +type is recommended. + +=item MEDIUMINT + +The C type (only natively supported by MySQL) specifies a 24-bit +integer type able to hold values from -8388608 to 8388607. If the C +column attribute is specified, this allows values from 0 to 16777215. Due to +this being supported with the C attribute, or implemented as a larger +data type, an C C will always supported values up to +16777215. + +=item INT, INTEGER + +The C type specifies a 32-bit integer able to hold values from -2147483648 +to 2147483647. If the C column attribute is specified, the column +I support values from 0 to 4294967295, however this is B guaranteed. +If values larger than 2147483647 are needed, using the C type below is +recommended. C is an alias for C. + +=item BIGINT + +The largest integral type, C specifies a 64-bit integer value able to +hold values from -9223372036854775808 to 9223372036854775807. If specified as +C, the column I support values from 0 to 18446744073709551616, +but this is B guaranteed. If larger values are needed, use the C +type with a C value of C<0>. + +=back + +=head2 Float-point types + +=over 4 + +=item REAL, FLOAT + +The C type specifies a 32-bit floating-point (i.e. fractional) number, +accurate to 23 binary digits (which works out to I 6 decimal +digits). The values may be signed, and can range from at least as small as +10^-37 to at least as large as 10^37. For more precise values, the C +type is recommended. For exact precision (i.e. for monetary values), the +(often slower) C type is recommended. C is an alias for +C. + +=item DOUBLE + +The C type specifies a 64-bit floating-point (i.e. fractional) number, +accurate to 52 binary digits (I 15 decimal digits). The values +may be signed, and can range from at least as small as 10^-307 to at least as +large as 10^308 (except under Oracle - see below). For exact precision (i.e. +for monetary values), the (often slower) C type is recommended. + +Take note that Oracle doesn't properly support the full range supported by +other databases' C types - the smallest number supported (assuming +precision to digits) is 10^-113 - specifically, the number of digits after the +decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while +1.23456789012e-117 is not. The larger number Oracle supports is just less than +1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you +need to store numbers larger or smaller than this amount, you'll have to find +some other way to store your numbers (i.e. Math::BigFloat with a C). + +=back + +=head2 Aribtrary precision numbers + +=over 4 + +=item DECIMAL + +The C type is provided to support numbers of arbitrary precision. It +requires two attributes, C and C, where C specifies +the number of decimal places, and precision specifies the number of overall +digits. For example, C<123.45> has a C of 5, and a C of 2. +C<42> has a C or 2, and a C of 0. C must be less than +C, and C must not exceed 38. Also, although the value +stored and retrieved is completely accurate within it's given precision and +scale range, the accuracy available for comparisons (i.e. column = number) is +only reliably accurate to approximately the same level as DOUBLE's - that is, +about 15 digits. + +=back + +=head2 Character types + +=over 4 + +=item CHAR + +The C type is used to specify a string of characters from 1 to 255 +characters long. It takes a C attribute which must be 255 or less, and +specifies the size of the column values - if not specified, 255 will be used. +This implementation's C type, for historic reasons, B pad +inserted values with spaces, but B trim trailing spaces when retrieving +and/or comparing values. Note that this is B SQL compliant C +behaviour - SQL-compliant C's are padded with spaces up to their size. + +What this ends up meaning is that for everything except MySQL, C columns +will be mapped to C columns. Note that even MySQL, which is the only +database for which C's are not automatically mapped into C's, +will I convert C columns to C columns if any +non-fixed-size datatype (anything other than a C or numeric types) is +used in or added to the table. As a general rule, C is preferred over +C except when dealing with columns whose values don't vary significantly +in length B are in a table that only contains fixed-size data types +(C's and numeric types). Everywhere else, use C's, since that's +what you'll be getting anyway. + +A C attribute is supported, which I indicates that comparisons +with this field should be case-sensitive. Note that this only works on +databases that actually have a case-sensitive C field - currently, only +MySQL. + +=item VARCHAR + +The C type is identical to the above C type B as +follows. Unlike a C, a C column does not take up C bytes +of storage space - typically the storage space is only slightly larger +(typically 1 byte) than the size of the value stored. As such, C's +are almost always preferred over columns, except for nearly-constant sized +data, or tables with all fixed-width data types (C's, C's, and +non-C numeric types). C columns will not be padded with +whitespace up to C, however trailing whitespace C be trimmed from +values. + +As with C, the C attribute I make the C values +case-sensitive for the matching purposes. + +=item TEXT + +The C type is similar to C types, except that they are always +case-insensitive for matching/equality, and can contain longer values. The +C type takes a C attribute which contains the length required - if +not provided, a value of approximately 2 billion is used. Note that the +maximum size of the column will usually be larger than the value you specify to +C - it simply indicates to the driver to use a field capable of at least +the size specified. The values of C fields are case-insensitive in terms +of matches and equality. The maximum C value, and the default, is +approximately 2 billion. + +Certain aliases are provided with implicit size defaults - C, +C, C, and C, which are equivelant to C +with C values of 255, 65535, 16777215, and 2147483647, respectively. + +Depending on the C value, certain databases _may_ use different +underlying types. MySQL, for example, uses the smallest possible type between +its native C, C, C, and C types. As +such, it is recommended that you use a sufficiently large C value unless +absolutely sure that you will never need a larger value. + +Also note that C types B support normal equality operations - in +fact, the only portable things that can be done with C columns is C tests (in GT::SQL this means "=" C) and C comparisons - but, +for portability with all supported databases, the argument of a C may not +exceed 4000 characters. + +Also note that the C value will be ignored by MySQL, which does not +support having default values on C columns. Everything else, however, +will properly support this, and the default will still be used when inserting +with GT::SQL even when using MySQL. Also note that the default value of +C types B exceed 3998 characters, due to limits imposed by some +databases. Longer indexes may work in some cases, but are not guaranteed - for +example, a table resync on MSSQL will not work. + +=item ENUM + +The C type is a MySQL-only type that supports certain fixed string +values. On non-MySQL databases, it is simply mapped to a C column. +It requires a C option which should have a value of an array reference +of string values that the ENUM should permit. The C type is generally +discouraged in favour of a C, C, or an +L column, all of which provide more flexibility +(i.e. if you want to add a new possible value) and are not a single +database-specific type. + +=back + +=head2 Date/time types + +All of the date/time types support by MySQL will be handled by GT::SQL, for +compatibility reasons. However, all types other than DATE and C +should be considered deprecated as cross-database compatibility is not possible +using these types. In particular, C will work exactly like a +C on every non-MySQL database; C
        ~; + for my $key (sort keys %$tags) { + my $val = $tags->{$key}; + $val = $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val = $dumper->dump(data => $val) if ref $val; + $val = GT::CGI::html_escape($val); + local $^W; + $val =~ s/ / /g; + $val =~ s|\n|
        \n|g; + if ((not exists $opts{-hide_long} or $opts{-hide_long}) and (my $num_lines = $val =~ y/\n//) > 26) { + my $id = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 0 .. 24]; + my $more_lines = $num_lines - 25; + $val =~ s{^((?:.*\n){25})}{$1($more_lines more lines)"; + } + $output .= qq|"; + } + $output .= qq~
        <$font>Available Variables
        <$font>$key| . (length $val ? qq|$val| : ' ') . "
        ~; + } + return \$output; +} +END_OF_SUB + +sub _parse { +# --------------------------------------------------------------- +# Sets the parsing options, and gets the code ref and runs it. +# + my ($self, $template, $opt) = @_; + + my $compress = exists $opt->{compress} ? $opt->{compress} : $self->{compress}; + local $self->{opt} = {}; + $self->{opt}->{strict} = exists $opt->{strict} ? $opt->{strict} : $self->{strict}; + $self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print}; + $self->{opt}->{escape} = exists $opt->{escape} ? $opt->{escape} : $self->{escape}; + $self->{opt}->{package} = exists $opt->{package} ? $opt->{package} : caller(1) || 'main'; + $self->{opt}->{func_code} = exists $opt->{func_code} ? $opt->{func_code} : $self->{func_code}; + $self->{opt}->{heap} = exists $opt->{heap} ? $opt->{heap} : $self->{heap}; + +# Set the root if this is a full path so includes can be relative to template. + if (substr($template, 0, 1) eq '/' or substr($template, 1, 1) eq ':') { + $self->{root} = substr($template, 0, rindex($template, '/')); + substr($template, 0, rindex($template, '/') + 1) = ''; + } + my $root = $self->{root}; + my $full_file = $self->{root} . '/' . $template; + my ($code, $dont_save, $files) = $self->{opt}->{print} == 2 + ? @{$FILE_CACHE_PRINT{$full_file}}{qw/code dont_save files/} + : @{$FILE_CACHE{$full_file}}{qw/code dont_save files/}; + + # Determine the newest mtime from the cache info; this won't be accurate + # until the template is completely parsed due to dynamic includes (which + # may be used without your knowledge as an optimization). + for (@$files) { + my $mtime = $_->[2]; + $self->{mtime} = $mtime if $mtime and (!$self->{mtime} or $self->{mtime} < $mtime); + } + + my $output = $code->($self); + return $output if $self->{opt}->{print} == 2; + + $LAST_MODIFIED = $self->{mtime}; + +# Compress output if requested. + if ($compress) { + $self->debug("Compressing output for template '$template'.") if $self->{_debug}; + + my ($pre_size, $post_size); + $pre_size = length $$output if $self->{_debug}; + $self->_compress($output); + $post_size = length $$output if $self->{_debug}; + + $self->debug(sprintf "Output reduced %.1f%%. Size before/after compression: %d/%d.", 100 * (1 - $post_size / $pre_size), $pre_size, $post_size) if $self->{_debug}; + } + return $$output; +} + +$COMPILE{_compile_template} = __LINE__ . <<'END_OF_SUB'; +sub _compile_template { +# ------------------------------------------------------------------- +# Loads the template parser and compiles the template and saves it +# to disk. +# + my ($self, $file, $full_compiled, $print) = @_; + $self->debug("Compiling template $file (into $full_compiled)") if $self->{_debug}; + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + + my ($code, $files) = $parser->parse( + $file, + { + root => $self->{root}, + include_root => $self->{include_root} + }, + ($print and $print == 2) + ); + + local *FH; + my $tmpfile = $full_compiled . "." . time . "." . $$ . "." . int(rand(10000)) . ".tmp"; + open FH, ">$tmpfile" or return $self->fatal(CANTOPEN => $tmpfile, "$!"); + my $localtime = localtime; + my $file_string = '[' . join(',', map { + my ($file, $path, $mtime, $size) = @$_; + for ($file, $path) { s/([\\'])/\\$1/g if defined } + "['$file'," . (defined $path ? "'$path'" : 'undef') . ",$mtime,$size]" + } @$files) . ']'; + + (my $escaped = $full_compiled) =~ s/(\W)/sprintf "_%x", ord($1)/ge; + print FH qq +|# This file is a compiled version of a template that can be run much faster +# than reparsing the file, yet accomplishes the same thing. You should not +# attempt to modify this file as any changes you make would be lost as soon as +# the original template file is modified. +# Editor: vim:syn=perl +# Generated: $localtime, using GT::Template::Parser v$GT::Template::Parser::VERSION +local \$^W; +{ + files => $file_string, + parser_version => $VERSION, + code => \\>::Template::parsed_template +}; +sub GT::Template::parsed_template { +$$code +}|; + close FH; + unless (rename $tmpfile, $full_compiled) { + unlink $tmpfile; + return $self->fatal(RENAME => $tmpfile, $full_compiled, "$!"); + } + chmod 0666, $full_compiled; + return; +} +END_OF_SUB + +$COMPILE{_compile_string} = __LINE__ . <<'END_OF_SUB'; +sub _compile_string { +# ----------------------------------------------------------------------------- +# Like _compile_template, except that this returns a code reference for the +# passed in string. +# Takes two arguments: The string, and print mode. If print mode is on, the +# code will print everything and return 1, otherwise the return will be the +# result of the template string. + my ($self, $string, $print) = @_; + $self->debug("Compiling string '$string' in " . (($print and $print == 2) ? "stream mode" : "return mode")) if $self->{_debug}; + if (!$string) { + $self->debug("Actual parsing skipped for empty or false string '$string'") if $self->{_debug}; + if ($print and $print == 2) { + return sub { print $string }; + } + else { + return sub { \$string }; + } + } + + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + my ($eval) = $parser->parse( + $string, + { + root => $self->{root}, + include_root => $self->{include_root}, + string => $string + }, + ($print and $print == 2) + ); + + my $code; + local ($@, $^W); + eval { # Catch tainted data + eval "sub GT::Template::parsed_template { $$eval }"; + $code = \>::Template::parsed_template unless $@; + }; + + unless (ref $code eq 'CODE') { + return $self->fatal(CANTRUNSTRING => "sub GT::Template::parsed_template { $$eval }", "$@"); + } + return $code; +} +END_OF_SUB + +$COMPILE{_call_func} = __LINE__ . <<'END_OF_SUB'; +sub _call_func { +# ----------------------------------------------------------------------------- +# Calls a function. The arguments are set in GT::Template::Parser. If the +# function returns a hash, it is added to $self->{VARS} _unless_ the 'set' +# option is provided and true. The result of the function is escaped, if +# escape mode is turned on. +# + my ($self, $torun, $allow_strict, $set, @args) = @_; + my $aliased; + if (exists $self->{ALIAS}->{$torun}) { + $torun = $self->{ALIAS}->{$torun}; + $aliased = 1; + } + no strict 'refs'; + my $rindex = rindex($torun, '::'); + my $package; + $package = substr($torun, 0, $rindex) if $rindex != -1; + my ($code, $ret); + my @err = (); + my $ok = 0; + if ($package) { + my $disabled; + if ($aliased) { + if ($self->{disable}->{alias_args} and @args) { + $disabled = $ERRORS->{DISABLED_ALIASARGS}; + } + } + elsif ($self->{disable}->{functions}) { + $disabled = $ERRORS->{DISABLED_FUNC}; + } + elsif ($self->{disable}->{function_args} and @args) { + $disabled = $ERRORS->{DISABLED_FUNCARGS}; + } + elsif ($self->{disable}->{function_restrict} and $torun !~ /$self->{disable}->{function_restrict}/) { + $disabled = sprintf $ERRORS->{DISABLED_FUNCRE}, $torun; + } + + if ($disabled) { + push @err, $disabled; + } + else { + my $func = substr($torun, rindex($torun, '::') + 2); + (my $pkg = $package) =~ s,::,/,g; + until ($ok) { + local ($@, $SIG{__DIE__}); + my $req = eval { require "$pkg.pm" }; + if (!$req) { + push @err, $@; + # Remove file from %INC so that future require's don't succeed: + delete $INC{"$pkg.pm"}; + } + elsif (defined(&{$package . '::' . $func}) + or defined &{$package . '::AUTOLOAD'} and %{$package . '::COMPILE'} and exists ${$package . '::COMPILE'}{$func} + ) { + $ok = 1; + $code = \&{$package . '::' . $func}; + last; + } + else { + push @err, sprintf($ERRORS->{NOSUB}, "$package\::$func", "$pkg.pm"); + } + my $pos = rindex($pkg, '/'); + $pos == -1 ? last : (substr($pkg, $pos) = ""); + last unless $self->{pkg_chop}; + } + } + } + elsif (ref $self->{VARS}->{$torun} eq 'CODE') { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun}; + $ok = 1; + } + } + elsif ($self->{DELAY_VARS}->{$torun}) { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun} = $self->{DELAY_VARS}->{$torun}->{$torun}; + delete $self->{DELAY_VARS}->{$torun}; + $ok = 1; + } + } + elsif ($CORE{$torun}) { + if ($self->{disable}->{core_functions}) { + push @err, $ERRORS->{DISABLED_COREFUNCS}; + } + else { + $code = $CORE{$torun}; + $ok = 1; + } + } + + if ($ok) { + local $PARSER = $self; + if ($self->{opt}->{heap}) { + push @args, $self->{opt}->{heap} + } + if ($package and ref($self->{opt}->{func_code}) eq 'CODE') { + $ret = $self->{opt}->{func_code}->($torun, @args); + } + else { + $ret = $code->(@args); + } + if (ref $ret eq 'HASH' and not $set) { + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + $ret = ''; + } + } + elsif ($package) { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{CANTLOAD}, $package, join(",
        \n", @err)) : ''; + } + else { + if (@err) { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{CANTCALLCODE}, $torun, join(",
        \n", @err)) : ''; + } + else { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{NOTCODEREF}, $torun) : ''; + } + } + + $ret = '' if not defined $ret; + $ret = (ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE') ? $$ret : ($set and ref $ret) ? $ret : $self->{opt}->{escape} ? GT::CGI::html_escape($ret) : $ret; + return $ret; +} +END_OF_SUB + +$COMPILE{_compress} = __LINE__ . <<'END_OF_SUB'; +sub _compress { +# ----------------------------------------------------------------------------- +# Compress html by removing extra space (idea/some re from HTML::Clean). +# Avoids compressing pre tags. +# + my ($self, $text) = @_; + if ($$text =~ /))( + my $html = $1; + my $pre = $2 || ''; + $html =~ s/\s+\n/\n/g; + $html =~ s/\n\s+\s{2,} />/g; + $html =~ s/<\s+/\s{2,} />/g; + $$text =~ s/<\s+/ $_[2], strict => $_[3] } if not ref $opt and defined $opt; + + $opt ||= { escape => 0, strict => 0 }; + $opt->{merge} = 1 if not exists $opt->{merge}; + $opt->{return_ref} = 0 unless $opt->{return_ref}; + + my ($ret, $good) = ('', 1); + if (ref($str) eq 'HASH') { + $ret = $str; + } + elsif (exists $self->{ALIAS}->{$str}) { + $ret = $self->_call_func($str); + } + elsif (my ($val) = $self->_raw_value($str)) { + if (ref $val eq 'CODE') { + local $PARSER = $self; + $ret = $val->($self->vars, $self->{opt}->{heap} || ()); + + $ret = '' if not defined $ret; + } + else { + $ret = $val; + $ret = '' if not defined $ret; + } + } + elsif ($str eq 'TIME') { + return time; + } + else { + $good = 0; + } + + if (not $good) { + return $opt->{strict} ? sprintf($ERRORS->{UNKNOWNTAG}, $str) : undef; + } + if ($opt->{return_ref} and (ref $ret eq 'HASH' or ref $ret eq 'ARRAY')) { + return $ret; + } + if (ref $ret eq 'HASH') { + return 1 if not $opt->{merge}; + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + return; + } + return if not defined $ret; + return $$ret if ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE'; + return $ret if not $opt->{escape}; + $ret =~ s/&/&/g; + $ret =~ s//>/g; + $ret =~ s/"/"/g; + return $ret; +} + +sub _raw_value { +# ----------------------------------------------------------------------------- +# Gets a raw value. If the variable doesn't exist, returns an empty list (or +# undef, in scalar context). +# + my ($self, $key) = @_; + if (exists $self->{VARS}->{$key} and $self->{DELAY_VARS}->{$key}) { + $self->{VARS}->{$key} = $self->{DELAY_VARS}->{$key}->{$key}; + delete $self->{DELAY_VARS}->{$key}; + } + return $self->{VARS}->{$key} if exists $self->{VARS}->{$key}; + return time if $key eq 'TIME'; + + if ($key =~ /^\w+(?:\.\$?\w+)+$/) { + my $cur = $self->{VARS}; + my @k = split /\./, $key; + for (my $i = 0; $i < @k; $i++) { + if ($k[$i] =~ /^\$/) { + my $val = $self->_get_var(substr($k[$i], 1)); + $val = '' if not defined $val; + my @pieces = split /\./, $val; + @pieces = '' if !@pieces; + splice @k, $i, 1, @pieces; + $i += @pieces - 1 if @pieces > 1; + } + } + KEY: while (@k) { + # for a.b.c: + # @k = ('a', 'b', 'c') + # @i = ('a.b.c', 'a.b', 'a') + # This is needed because "a.b.c" will look for key "b.c" in hash "a" before key "b" + my @i = map join('.', @k[0 .. $_]), reverse 1 .. $#k; + push @i, shift @k; + + { + if (ref $cur eq 'CODE') { + # current node (e.g. a.b for a.b.c) is a code ref; call it, and try again + $cur = $cur->($self->{opt}->{heap} || ()); + redo; + } + elsif (ref $cur eq 'ARRAY' and $i[-1] =~ /^\d+$/) { + return if $i[-1] > $#$cur; + $cur = $cur->[$i[-1]]; + } + elsif (ref $cur eq 'ARRAY' and $i[-1] =~ /^last(\d+)?$/) { + my $negi = $1 || 1; + return if $negi > @$cur; + $cur = $cur->[-$negi]; + } + elsif (!@k and ref $cur eq 'ARRAY' and $i[0] eq 'length') { + $cur = scalar @$cur; + } + elsif (ref $cur eq 'HASH' or UNIVERSAL::isa($cur, 'GT::Config')) { + my $exists; + for (0 .. $#i) { + if (exists $cur->{$i[$_]}) { + splice @k, 0, $#i-$_ unless $_ == $#i; + $cur = $cur->{$i[$_]}; + $exists = 1; + last; + } + } + return unless $exists; + } + elsif (UNIVERSAL::can($cur, 'param') and my ($val) = $cur->param($i[0])) { + $cur = $val; + last KEY; + } + else { + return; + } + } + } + + return $cur; + } + + return; +} + +sub _include { +# ----------------------------------------------------------------------------- +# Perform a runtime include of a file. +# + my ($self, $template, $allow_path) = @_; + + $allow_path = $self->{varinc_allow_path} unless defined $allow_path; + + if ($template eq '.' or $template eq '..' or ($template =~ m{[/\\]} and !$allow_path)) { + return sprintf $ERRORS->{BADINC}, $template, 'Invalid characters in filename'; + } + + if (++$self->{include_safety} > GT::Template::INCLUDE_LIMIT) { + return $ERRORS->{DEEPINC}; + } + + if ($allow_path and $self->{include_root} and $template =~ m{^(?:[a-zA-Z]:)?[/\\]}) { + # Remove the drive letter on Windows + $template =~ s/^[a-zA-Z]://; + $template = $self->{include_root} . $template; + +# A small (hopefully temporary) hack to fix the problem where the compiled +# files end up in the included template's directory. + if ($self->{root}) { + $template =~ s|^\Q$self->{root}\E[/\\]||; + } + } + + my $opt = $self->{opt}; + my $print = $self->{print}; + my $streaming = $print && $print == 2; + $self->load_template($template, $streaming ? 2 : 0) unless $self->{skip_mod_check}->{$template}++; + + $self->debug("Parsing dynamic include '$template' with (print => @{[$opt->{print}||0]}, compress => @{[$opt->{compress}||0]}, strict => @{[$opt->{strict}||0]}, escape => @{[$opt->{escape}||0]})") if $self->{_debug}; + + my $ret = $self->_parse($template, $opt); + + --$self->{include_safety}; + + return $streaming ? '' : $ret || ''; +} + +1; + +__END__ + +=head1 NAME + +GT::Template - Gossamer Threads template parser + +=head1 SYNOPSIS + + use GT::Template; + my $var = GT::Template->parse('file.txt', { key => 'value' }); + ... + print $var; + +or + + use GT::Template; + GT::Template->parse_print('file.txt', { key => 'value' }); + +or + + use GT::Template; + GT::Template->parse_stream('file.txt', { key => 'value' }); + +or + + use GT::Template; + my $parser = GT::Template->new; + $parser->parse('file.txt', { key => 'value' }); + +=head1 DESCRIPTION + +GT::Template provides a simple way (one line) to parse a template (which +can be either a file or a string) and make sophisticated replacements. + +It supports simple replacements, conditionals, function calls, including other +templates, and more. + +Additionally, through using pre-compiled files, subsequent parses of a template +will be very fast. + +=head2 Template Syntax + +The template syntax documentation has moved - it is now documented in +L. + +=head2 parse + +This option parses a template, and returns the value of the parsed template. +See L for a description of the possible parse parameters. + +=head2 parse_print + +This option parses a template, and prints it. See L for a +description of the possible parse_print parameters. + +=head2 parse_stream + +This option parses a template, and prints each part of it as the parse occurs. +It should only be used in situations where streaming content is required as it +is measurably slower than the parse_print alternative. See L +for a description of the possible parse_stream parameters. + +=head2 Parse Options + +=head3 Filename + +The first argument to parse()/parse_print()/parse_stream() (hereafter referred +to simply as parse()) is the full or relative (to the current working +directory) path to the file to parse. + +=head3 Variables + +The second argument is a hash reference of template variables that will be +available in the parsed template (see L). Arbitrary +hash/array data structure access is supported (see +L). + +Loops are supported by providing an array reference or code reference as a +value; array reference loops are generally preferred as they enable the loop to +be used multiple times and support the <%loopvar.length%> syntax. + +=head3 Options + +The third argument (which is not required) takes additional options that change +the way a parse is performed. The available options (there are more, however +their use is discouraged) are as follows. + +=over 4 + +=item * string => $template + +Passing in C $template> will use $template as for the template +content instead of reading the file specified as the first parse() argument. +If provided, the first argument to parse() (the filename) is ignored. + +=item * compress => 1 + +Setting compress => 1 will compress all white space generated by the program. +This is usually acceptable for HTML, reducing page sizes by typically 10-20%, +but should not be used for non-HTML templates. The default is 0 (no +compression). This option has no effect when using parse_stream(). + +=item * strict => 0 + +If set to 1, attempting to use a tag that does not exist will display an +"Unknown tag 'tagname'" error. If strict is set to 0, using an unset tag will +not display anything. + +=item * escape => 1 + +If enabled, this option will cause all variables to be HTML escaped before +being included on a page. Enabling this option is strongly recommended. +all variables before they are printed. Tag values that should not be escaped +should be passed as scalar references (\$foo or \''). + +This option currently defaults to 0, but may eventually change to 1 - so +passing an explicit 1 or 0 value is strongly recommended. + +=item * disable => { ... } + +This can be used to disable certain GT::Template functionality. To disable a +particular feature, the hash reference passed to disable should contain a +C with a C<1> value, unless otherwise indicated. Feature names +are as follows: + +=over 4 + +=item * functions + +This can be used to disable Package::function calls, such as +C%Some::Package::function%E>. Note, however, that this does _not_ +disable aliased function calls (see below). + +=item * function_args + +This disables any function calls that specify arguments - for instance, +C%Some::Package::function(1)E>. Note that this does _not_ disable +passing arguments to aliased function calls (see below). + +=item * function_restrict + +This can be used to restrict function calls by limiting the available +functions. It takes a regular expression as an argument, which will be tested +against the fully qualified function name - any function that does not match +the regular expression will not be called. For example, to only allow +functions in 'Package::One' and 'Second::Package' to be called, you could use: + + function_restrict => '^(?:Package::One|Second::Package)::\w+$' + +Like the above options, this does not restrict aliased function calls. + +=item * coderefs_args + +This can be specified to disable the calling of code reference variables with +arguments. Tags such as C%coderefname%E> and +C%coderefname()%E> will be allowed, but C%coderefname(1)%E> +will not. + +=item * alias_args + +This option can be used to disable the passing of arguments to aliased function +calls (see below). + +=item * core_functions + +Disables the use of core perl function wrappers such as substr and sprintf. + +=back + +=item * pkg_chop + +When calling a function such as <%Package::A::B::function%>, GT::Template will +first attempt to load Package/A/B.pm, then, if it fails, Package/A.pm, and so +on down to Package.pm, looking for Package::A::B::function in each file. This +behaviour is slow and often undesirable - it is recommended to properly split +up packages (that is, putting Package::A::B inside Package/A/B.pm instead of +Package/A.pm or Package.pm). The "package chopping" occurs if pkg_chop is set +to 1 (currently the default, but may change), and does not occur if pkg_chop is +set to 0 (recommended, but not the default for historic reasons). + +=item * heap + +If this is set, it will be added to the end of any other arguments passed to +functions called. + +=item * func_code + +When calling a function such as <%Package::function%>, you can override the +default behaviour of simply calling the function by providing a code reference +to C. Instead of calling Package::function(), your code reference +will be called with the string of the package to call (e.g. +'Package::function') and the arguments that would have been passed to the +function. The return value of your code will be used as if it was the return +value from the real function. + +=item * begin + +=item * end + +C and C can be used to change the characters that start and end a +template tag. These default to C%> for C, and C<%E> for +C. For example, if you changed C to C<[*> and C to C<*]>, you +would use C<[*tagname*]> for a normal tag, C<[*-- comment --*]> for a comment, +etc. + +=item * varinc_allow_path => 0 + +If enabled, this option will allow paths to be used in variable based includes. + +=back + +=head3 Aliases + +The forth option to parse is an optional hash of aliases to set up for +functions. The key should be the alias name and the value should be the +function to call when the alias is invoked. For example: + + print GT::Template->parse( + 'file.htm', + { key => 'value' }, + { compress => 1 }, + { myfunc => 'Long::Package::Name::To::myfunc' } + ); + +Now in your template you can do: + + <%myfunc('argument')%> + +Which will call C. + +=head2 vars + +Accessing variables from outside a template can be done by calling the +Cvars> method. For further details, please see +L. + +=head2 last_modified + +It is sometimes desirable to know the last modification date of a parsed +template (including includes). For this, the last_modified() method can be +used, subject to some caveats: + +=over 4 + +=item * Does not indicate that the page has not changed - it only indicates +that the I (and both static and dynamic includes) on the page have +not changed, not the output which can, of course, be affected by template +variables. In order to use this for determining the last modified time of an +output template, you need to combine this value with a last-modified date for +the data being provided as template variables. + +=item * Is only valid after the parse has finished. If the value is needed +before the output is printed (e.g. for an HTTP header), neither parse_print() +nor parse_stream() can be used. + +=item * Does not work with string parsing. There is no logical last-modified +time for strings aside from "now", so it is not calculated. + +=back + +=head1 EXAMPLES + +Parse the string contained in $template, making the 'key' tag available. + + my $parsed = GT::Template->parse(undef, { key => 'value' }, { string => $template }); + +Parse file.txt, compress the result, and print it. This is equivelant to +Cparse(...)>, but slightly faster. + + GT::Template->parse_print('file.txt', { key => 'value' }, { compress => 1 }); + +Print the output of the template it as it is parsed, not after entirely parsed. +This will output the same as the above command would without the "compress" +option, but is slower (unless, of course, streaming is needed). + + GT::Template->parse_stream('file.txt', { key => 'value' }); + +Don't display warnings on invalid keys: + + GT::Template->parse_print('file.txt', { key => 'value' }, { strict => 0 }); + +=head1 SEE ALSO + +L - Documentation/tutorial for GT::Template template +tags. + +L - Interface for accessing/manipulating template tags from +Perl code. + +L - Documentation for GT::Template template +inheritance. + +=head1 COPYRIGHT + +Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Template.pm,v 2.172 2011/05/13 23:56:51 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/GT/Template/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/GT/Template/Editor.pm new file mode 100644 index 0000000..370ba90 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/GT/Template/Editor.pm @@ -0,0 +1,417 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Template::Editor +# Author: Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Editor.pm,v 2.20 2009/05/09 17:28:30 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# A module for editing templates via an HTML browser. +# + +package GT::Template::Editor; +# =============================================================== +use strict; +use GT::Base; +use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS); +@ISA = qw/GT::Base/; +$VERSION = sprintf "%d.%03d", q$Revision: 2.20 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0; +$ATTRIBS = { + cgi => undef, + root => undef, + backup => undef, + default_dir => '', + default_file => '', + date_format => '', + class => undef, + skip_dir => undef, + skip_file => undef, + select_dir => 'tpl_dir', + demo => undef +}; +$ERRORS = { + CANTOVERWRITE => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.", + CANTCREATE => "Unable to create new files in directory %s. Please set permissions properly and save again.", + CANTMOVE => "Unable to move file %s to %s: %s", + CANTMOVE => "Unable to copy file %s to %s: %s", + FILECOPY => "File::Copy is required in order to make backups.", +}; + +sub process { +# ------------------------------------------------------------------ +# Loads the template editor. +# + my $self = shift; + + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || ''; + my $tpl_text = ''; + my $error_msg = ''; + my $success_msg = ''; + my ($local, $restore) = (0, 0); + +# Check the template directory and file + if ($selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..') { + $error_msg = "Invalid template directory $selected_dir"; + $selected_dir = ''; + $selected_file = ''; + } + if ($selected_file =~ m[[\\/\x00-\x1f]]) { + $error_msg = "Invalid template $selected_file"; + $selected_dir = ''; + $selected_file = ''; + } + +# Create the local directory if it doesn't exist. + my $tpl_dir = $self->{root} . '/' . $selected_dir; + my $local_dir = $tpl_dir . "/local"; + if ($selected_dir and ! -d $local_dir) { + mkdir($local_dir, 0777) or return $self->error('MKDIR', 'FATAL', $local_dir, "$!"); + chmod(0777, $local_dir); + } + my $dir = $local_dir; + + my $save = $self->{cgi}->param('tpl_name') || $self->{cgi}->param('tpl_file'); +# Perform a save if requested. + if ($self->{cgi}->param('saveas') and $save and !$self->{demo}) { + $tpl_text = $self->{cgi}->param('tpl_text'); + if (-e "$dir/$save" and ! -w _) { + $error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $save); + } + elsif (! -e _ and ! -w $dir) { + $error_msg = sprintf($ERRORS->{CANTCREATE}, $dir); + } + else { + if ($self->{backup} and -e "$dir/$save") { + $self->copy("$dir/$save", "$dir/$save.bak"); + } + local *FILE; + open (FILE, "> $dir/$save") or return $self->error(CANTOPEN => FATAL => "$dir/$save", "$!"); + $tpl_text =~ s/\r\n/\n/g; + print FILE $tpl_text; + close FILE; + chmod 0666, "$dir/$save"; + $success_msg = "File has been successfully saved."; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$save"; + $selected_file = $save; + $tpl_text = ''; + } + } +# Delete a local template (thereby restoring the system template) + elsif (my $restore = $self->{cgi}->param("restore") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$restore", "$dir/$restore.bak")) { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!"; + } + } + else { + if (unlink "$dir/$restore") { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to remove $dir/$restore: $!"; + } + } + } +# Delete a local template (This is like restore, but happens when there is no system template) + elsif (my $delete = $self->{cgi}->param("delete") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$delete", "$dir/$delete.bak")) { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!"; + } + } + else { + if (unlink "$dir/$delete") { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to remove $dir/$delete: $!"; + } + } + } + +# Load any selected template file. + if ($selected_file and ! $tpl_text) { + if (-f "$dir/$selected_file") { + local (*FILE, $/); + open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$selected_file"; + } + elsif (-f "$self->{root}/$selected_dir/$selected_file") { + local (*FILE, $/); + open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + } + else { + $selected_file = ''; + } + } + +# Load a README if it exists. + my $readme; + if (-e "$dir/README") { + local (*FILE, $/); + open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)"; + $readme = ; + close FILE; + } + +# Set the textarea width and height. + my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 25; + my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 100; + my $file_select = $self->template_file_select; + my $dir_select = $self->template_dir_select; + $tpl_text = $self->{cgi}->html_escape($tpl_text); + my $stats = $selected_file ? $self->template_file_stats($selected_file) : {}; + + if ($self->{demo} and ($self->{cgi}->param('saveas') or $self->{cgi}->param("delete") or $self->{cgi}->param("restore"))) { + $error_msg = 'This feature has been disabled in the demo!'; + } + return { + tpl_name => $selected_file, + tpl_file => $selected_file, + local => $local, + restore => $restore, + tpl_text => \$tpl_text, + error_message => $error_msg, + success_message => $success_msg, + tpl_dir => $selected_dir, + readme => $readme, + editor_rows => $editor_rows, + editor_cols => $editor_cols, + dir_select => $dir_select, + file_select => $file_select, + %$stats + }; +} + +sub _skip_files { + my ($skip, $file) = @_; + return 1 if $skip->{$file} + or substr($file, 0, 1) eq '.' # skip dotfiles + or substr($file, -4) eq '.bak'; # skip .bak files + foreach my $f (keys %$skip) { + my $match = quotemeta $f; + $match =~ s/\\\*/.*/g; + $match =~ s/\\\?/./g; + return 1 if $file =~ /^$match$/; + } + return; +} + +sub template_file_select { +# ------------------------------------------------------------------ +# Returns a select list of templates in a given dir. +# + my $self = shift; + my $path = $self->{root}; + my %files; + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || $self->{default_file} || 'default'; + $selected_file = $self->{cgi}->param('tpl_name') if $self->{cgi}->param('saveas'); + my %skip; + if ($self->{skip_file}) { + for (@{$self->{skip_file}}) { + $skip{$_}++; + } + } + else { + $skip{README} = $skip{'language.txt'} = $skip{'globals.txt'} = 1; + } + +# Check the template directory + return if $selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..'; + + my $system_dir = $path . "/" . $selected_dir; + my $local_dir = $path . "/" . $selected_dir . '/local'; + foreach my $dir ($system_dir, $local_dir) { + opendir (TPL, $dir) or next; + while (defined(my $file = readdir TPL)) { + next unless -f "$dir/$file" and -r _; + next if _skip_files(\%skip, $file); + + $files{$file} = 1; + } + closedir TPL; + } + my $f_select_list = '{class}; + $d_select_list .= ">\n"; + foreach (sort @dirs) { + $d_select_list .= qq'
        +<$FONT>Post Install Message:
        <$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~ +<$FONT>Install Code:<$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~ +<$FONT>Uninstall Code:<$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~ +~; + return $output; +} + +sub install_as_form { +# ---------------------------------------------------------------- +# Returns the install information as a form. +# + my $self = shift; + $self->_load_install; + my $output = qq~ +<$FONT>Pre Install Message:
        + <$FONT> +<$FONT>Post Install Message:
        + <$FONT> +<$FONT>Install Code:
        + <$FONT> +<$FONT>Uninstall Code:
        + <$FONT> +~; + 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~ +<$FONT>$hook_name ($prepost)<$FONT>$code + ~; + } + } + else { + $output = qq~ +<$FONT>No hooks installed + ~; + } + return $output; +} + +sub hooks_as_form { +# ---------------------------------------------------------------- +# Returns plugin hooks as form. +# + my $self = shift; + my $output; + if (@{$self->{hooks}}) { + $output = qq~ +<$FONT>Installed Hooks + ~; + my $i = 0; + foreach my $hook (@{$self->{hooks}}) { + my ($hook_name, $prepost, $code) = @$hook; + $output .= qq~ +<$FONT>$hook_name ($prepost) => $code<$FONT>Delete: + ~; + $i++; + } + } + my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::"; + $output .= qq~ +<$FONT>Add New Hook +<$FONT>Hook: + <$FONT>Code: + ~; + 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~ +<$FONT>$menu_name<$FONT>=> $menu_url + ~; + } + } + else { + $output = qq~ +<$FONT>No Admin Menu options installed + ~; + } + return $output; +} + +sub admin_menu_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (@{$self->{admin_menu}}) { + $output = qq~ +<$FONT>Installed Admin Menu options + ~; + 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~ +<$FONT>$menu_name => $menu_url<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Menu +<$FONT>Name: + <$FONT>URL: + ~; + 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~ +<$FONT>~ . _escape_html($key) . qq~<$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~ + ~; + } + } + else { + $output = qq~ +<$FONT>No user options installed + ~; + } + return $output; +} + +sub options_as_form { +# ---------------------------------------------------------------- +# Returns meta info + version as form. +# + my $self = shift; + my $output; + if (keys %{$self->{options}}) { + $output = qq~ +<$FONT>Installed User options + ~; + my $i = 0; + foreach my $key (sort keys %{$self->{options}}) { + $output .= qq~ +<$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~<$FONT>Delete: + ~; + $i++; + } + } + $output .= qq~ +<$FONT>Add New Option +<$FONT>Name: + <$FONT>Default: + ~; + 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~ +<$FONT>$name<$FONT>$size + ~; + $num_files++; + } + } + if (! $num_files) { + $output = qq~ +<$FONT>No extra files installed + ~; + } + 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~ +<$FONT>$name<$FONT>($size) + ~; + $num_files++; + } + } + if ($num_files) { + $output = qq~ +<$FONT>Installed Files +$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 = <{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; + 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Installer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Installer.pm new file mode 100644 index 0000000..d5daca8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Installer.pm @@ -0,0 +1,266 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt 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.15 $ =~ /(\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', status], ...])"); + } + if (ref $hooks->[0] ne 'ARRAY') { + $hooks = [ $hooks ]; + } + foreach my $hook (@$hooks) { + my ($hookname, $prepost, $action, $status) = @$hook; + if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) { + die "Invalid hook argument. Must be pre/post, not: $prepost"; + } +# Allow a hook to be installed as disabled by default, but for backwards compatibility, it has to be a 0 (not just a false value). + $status = (defined $status and $status ne '' and $status == 0) ? 0 : 1; + push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, $status]; + } + 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 %$opts) { + $registry->{$key} = $opts->{$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', status]); + $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 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 + +=item status + +Whether or not the hook will be enabled or disabled. For backwards +compatibility, if this option is set to anything but '0' then the hook will be +enabled. + +=back + +C returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_menu + +C 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 returns 1 on success, undef on failure with the error +message in $GT::Plugins::error. + +=head2 install_options + +C 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 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.15 2006/11/22 01:21:14 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Manager.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Manager.pm new file mode 100644 index 0000000..9aadb55 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Manager.pm @@ -0,0 +1,1189 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Manager.pm,v 1.63 2006/10/18 23:59:36 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to manage installed and uninstalled +# plugins. +# + +package GT::Plugins::Manager; +# ================================================================== +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.63 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + cfg => undef, + cgi => undef, + tpl_root => '.', + tpl_prefix => '', + prefix => '', + plugin_dir => undef, + plugin => undef, + plugin_name => undef, + tar => undef, + prog_ver => undef, + prog_reg => undef, + prog_name => undef, + # The program init (e.g. admin) path; if set, this is passed to the plugin + # server and also changes the way download_gossamer() returns errors: + prog_init => undef, + prog_user_cgi => undef, + prog_admin_cgi => undef, + prog_images => undef, + prog_libs => undef, + base_url => undef, + func_url => undef, + path_to_perl => undef, + perl_args => 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}); +} + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to manager"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_man_do') || ''; + my $vars = {}; + my $page = 'plugin_manager_list.html'; + + CASE: { + ($action eq 'pre_install') and do { + $vars = $self->pre_install; + $page = 'plugin_manager_pre_install.html'; + last CASE; + }; + ($action eq 'install') and do { + $vars = $self->install; + last CASE; + }; + ($action eq 'pre_uninstall') and do { + $vars = $self->pre_uninstall; + $page = 'plugin_manager_pre_uninstall.html'; + last CASE; + }; + ($action eq 'uninstall') and do { + $vars = $self->uninstall; + last CASE; + }; + ($action eq 'pre_delete') and do { + $page = 'plugin_manager_delete.html'; + last CASE; + }; + ($action eq 'delete') and do { + $vars = $self->delete; + last CASE; + }; + ($action eq 'hooks') and do { + $vars = $self->set_hooks; + $page = 'plugin_manager_hooks.html'; + last CASE; + }; + ($action eq 'edit_installed') and do { + $vars = $self->edit_installed; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit.html'; + last CASE; + }; + ($action eq 'edit_uninstalled') and do { + $vars = $self->edit_uninstalled; + $page = $vars->{error} ? 'plugin_manager_list.html' : 'plugin_manager_edit_files.html'; + last CASE; + }; + ($action eq 'download') and do { + $page = 'plugin_manager_download.html'; + last CASE; + }; + ($action eq 'download_gossamer') and do { + $page = 'plugin_manager_download.html'; + $vars = $self->download_gossamer; + last CASE; + }; + ($action eq 'download_url') and do { + $vars = $self->download_url; + last CASE; + }; + ($action eq 'download_file') and do { + $vars = $self->download_file; + last CASE; + }; + }; + if ($page eq 'plugin_manager_list.html') { + $vars->{installed} = $self->installed_plugins_html; + $vars->{uninstalled} = $self->uninstalled_plugins_html; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + foreach my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +# ------------------------------------------------------------------------------------------------- # +# Installing/Uninstalling Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub pre_install { +# ---------------------------------------------------------------- +# Display pre-installation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => $GT::Plugins::error }; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return { error => $GT::Plugins::error }; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $pre_code; + { + no strict 'refs'; + $pre_code = ${$plugin_pkg . '::'}{'pre_install'}; + } + my $message = 'No pre installation message supplied.'; + if (defined $pre_code and defined &{$pre_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $pre_code->(); + }; + if ($@) { + $message = "Error running installation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + $message = ${$plugin_pkg . "::error"} || "No error message provided."; + } + } + +# Check for overwriting. + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + if (-e $install_to) { + my $old_plugin = $self->installed_plugin_info($plugin_name); + my $old_version = $old_plugin ? $old_plugin->{version} : "(Can't load installed: $GT::Plugins::error)"; + my $new_plugin = $self->uninstalled_plugin_info($plugin_name); + my $new_version = $new_plugin ? $new_plugin->{version} : "(Can't load uninstalled: $GT::Plugins::error)"; + + return { instructions => $message, old_version => $old_version, new_version => $new_version, confirm => 1 }; + } + else { + return { instructions => $message }; + } +} + +sub install { +# ---------------------------------------------------------------- +# Install the plugin. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_inst = $self->{cgi}->param('skip_install'); + + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $install_to = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + +# Get the main code, and save it. + my $plugin_code = $tar->get_file("$plugin_name.pm") or return { error => "Unable to locate the $plugin_name.pm file in tar" }; + +# Save the code. + open (FILE, "> $install_to") or return { error => "Unable to create plugin file: $install_to. Reason: $!" }; + print FILE $plugin_code->body_as_string; + close FILE; + +# Add the plugin to the config. + delete $self->{cfg}->{$plugin_name}; + + $self->{cfg}->{$plugin_name}->{meta} = $plugin->{meta}; + $self->{cfg}->{$plugin_name}->{version} = $plugin->{version}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Run the install code if requested. + my ($message, $error); + + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $code; + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{install}; + } + if ($self->{cgi}->param('skip_install')) { + $message = "Installation code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $code->($installer, $tar); + }; +# Oh, oh, didn't install properly. + if ($@) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + return { error => "Error running installation code: $@" }; + } + if (! defined $message) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink $install_to; + no strict 'refs'; + $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided. ($@)"; + return { error => "Unable to install plugin: '$message'" }; + } + } + else { + $message = "No installation code found."; + } + +# Move the tar file to the Installed directory. + my $move_from = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + $tar->close_tar; # Need to close the tar file. + + rename($move_from, $move_to) or return { error => "Unable to move plugin from $move_from => $move_to ($!)" }; + +# Installed ok, return results. + if ($error) { + return { error => $error, reload => 1 }; + } + else { + my $output = qq~ +

        Plugin $plugin_name Installed
        +The plugin has been successfully installed.

        +Installation Notes:
        +$message +

        + ~; + return { results => $output, reload => 1 }; + } +} + +sub pre_uninstall { +# ---------------------------------------------------------------- +# Display pre-uninstallation message. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!", plugin_name => '' }; + my $tar = $self->_open_tar($plugin_name, 'Installed') or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + my $post_code; + { + no strict 'refs'; + $post_code = ${$plugin_pkg . '::'}{'pre_uninstall'}; + } + my $message = 'No pre uninstallation message supplied.'; + if (defined $post_code and defined &{$post_code}) { + local ($@, $SIG{__DIE__}, $^W); + eval { + $message = $post_code->(); + }; + if ($@) { + $message = "Error running uninstallation code: $@"; + } + if (! defined $message) { + no strict 'refs'; + my $error = ${$plugin_pkg . "::error"}; + $message = $error || "No error message provided."; + } + } + return { instructions => $message }; +} + +sub uninstall { +# ---------------------------------------------------------------- +# Display uninstallation message. +# + my $self = shift; + + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $skip_uninst = $self->{cgi}->param('skip_uninstall'); + my $remove_from = $self->{plugin_dir} . "/" . $plugin_name . ".pm"; + my $tar = $self->_open_tar($plugin_name, 'Installed'); + my $move_from = $self->{plugin_dir} . "/Installed/" . $plugin_name . ".tar"; + my $move_to = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + if (! $tar) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + unlink($remove_from); + return { error => "Unable to load tar file: $GT::Plugins::error" }; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + if (! $plugin) { + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $tar->close_tar; + unlink($remove_from); + rename($move_from, $move_to); + return { error => "Unable to load uninstall file: $GT::Plugins::error" }; + } + +# Run any uninstallation code. + my ($code, $output, $error); + { + no strict 'refs'; + $code = ${$plugin_pkg . "::"}{uninstall}; + } + if ($self->{cgi}->param('skip_uninstall')) { + $output = "Uninstall code skipped."; + } + elsif (defined $code and defined &{$code}) { + require GT::Plugins::Installer; + my $args; + foreach my $attrib (keys %$ATTRIBS) { + $args->{$attrib} = $self->{$attrib}; + } + my $installer = new GT::Plugins::Installer($args); + + local ($@, $SIG{__DIE__}, $^W); + eval { + $output = $code->($installer, $tar); + }; + if ($@) { + $error = "Error in uninstall code: $@"; + } + if (! $output and ! $error) { + $output = "Uninstall completed."; + } + } + else { + $output = "No uninstall code found."; + } + +# Remove the plugin from the config. + delete $self->{cfg}->{$plugin_name}; + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + +# Remove the .pm file. + unlink($remove_from) or return { error => "Unable to remove tar file: $remove_from. Reason: $!" }; + +# Move the tar file back to the Uninstalled directory. + $tar->close_tar; # Need to close the tar file. + rename($move_from, $move_to) or return { error => "Unable to place plugin back into Uninstalled directory: $move_from => $move_to ($!)" }; + + return { results => $output, reload => 1, error => $error }; +} + +# ------------------------------------------------------------------------------------------------- # +# Editing Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub edit_installed { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + if (! exists $self->{cfg}->{$plugin_name}) { + return { error => "Invalid plugin name: $plugin_name" }; + } + +# Update the plugin if requested. + my ($results, $reload); + if ($self->{cgi}->param('edit')) { + my %enabled_hooks = map { $_ => 1 } $self->{cgi}->param('hooks'); + my %enabled_menu = map { $_ => 1 } $self->{cgi}->param('menu'); + if (ref $self->{cfg}->{$plugin_name}->{hooks} eq 'ARRAY') { + my $i = 0; + foreach my $hook (@{$self->{cfg}->{$plugin_name}->{hooks}}) { + $hook->[3] = exists $enabled_hooks{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{menu} eq 'ARRAY') { + my $i = 0; + foreach my $menu (@{$self->{cfg}->{$plugin_name}->{menu}}) { + $menu->[2] = exists $enabled_menu{$i++} ? 1 : 0; + } + } + if (ref $self->{cfg}->{$plugin_name}->{user} eq 'ARRAY') { + + my %opts; + foreach my $option ( @{$self->{cfg}->{$plugin_name}->{user} || []} ) { + $opts{$option->[0]} = $option; + } + + foreach my $key ($self->{cgi}->param()) { + next if ($key !~ /^user-(.+)/); + my $real_key = $1; + my @values = $self->{cgi}->param($key); +# find out if the item is a checkbox, if it is, make sure that it's an arrayref + my $val = (uc($opts{$real_key}->[3]) eq 'CHECKBOX') ? [@values] : $values[0]; + foreach my $opt (@{$self->{cfg}->{$plugin_name}->{user}}) { + if ($opt->[0] eq $real_key) { + $opt->[1] = $val; + } + } + } + } + GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg}); + $results = "Plugin updated successfully."; + $reload = 1; + } + my $plugin = $self->{cfg}->{$plugin_name}; + my $hooks = $self->load_hooks($plugin_name); + my $menu = $self->load_menu($plugin_name); + my $opts = $self->load_options($plugin_name); + + return { hooks => $hooks, menu => $menu, options => $opts, %{$plugin->{meta}}, results => $results, reload => $reload }; +} + +sub edit_uninstalled { +# ---------------------------------------------------------------- +# Edit a requested plugin. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled') or return { error => "Unable to open tar file: $GT::Plugins::error" }; + my $base = $self->{base_url}; + my ($output, $results, $body, $body_name); + + my $error = ''; + my $delete = $self->{cgi}->param('delete'); + if ($delete) { + $tar->remove_file($delete); + $tar->write ? ($results = "File $delete has been successfully removed!") : ($error = "Unable to delete file: $GT::Tar::error"); + } + my $add = $self->{cgi}->param('add'); + if ($add) { + my $body = $self->{cgi}->param('filebody'); + $tar->add_data(name => $add, body => $body); + $tar->write ? ($results = "File $add successfully added.") : ($error = "Unable to add file: $GT::Tar::error"); + } + my $edit = $self->{cgi}->param('edit'); + if ($edit) { + my $file = $tar->get_file($edit); + if ($file) { + $body = $file->body_as_string; + $body = $self->{cgi}->html_escape($body); + $body_name = $file->name; + } + } + my $save = $self->{cgi}->param('save'); + if ($save) { + my $file = $tar->get_file($save); + if ($file) { + my $body = $self->{cgi}->param('body'); + $body =~ s/\r//g; + $file->body($body); + $tar->write ? ($results = "File $save updated successfully.") : ($error = "Unable to save file: $GT::Tar::error"); + } + } + my $perl = $self->{cgi}->param('perl'); + if ($perl) { + my $file = $tar->get_file($perl); + if ($file) { + $results = $self->_syntax_check($file); + } + } + my $files = $tar->files; + + foreach my $file (@$files) { + my $name = $file->name; + next if ($name eq 'Wizard.pm'); + my $size = length $file->body_as_string; + + $output .= qq~ +$name ($size bytes) + + Edit | + Perl Check + ~; + $output .= qq~ + | Delete + ~ if (($name ne 'Install.pm') and ($name ne $plugin_name . '.pm')); + $output .= qq~ + + + ~; + } + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or ($error = "Unable to load install file: $GT::Plugins::error"); + $plugin->{meta} ||= {}; + $plugin->{meta}->{title} ||= $plugin_name; + $plugin->{meta}->{author} ||= 'Unknown'; + $plugin->{meta}->{url} ||= ''; + $plugin->{meta}->{description} ||= ''; + $plugin->{version} ||= 'Unknown'; + return { files => $output, %{$plugin->{meta}}, results => $results, body => $body, body_name => $body_name, inst_error => $error }; +} + +sub load_menu { +# ----------------------------------------------------------------- +# Returns the html to enable/disable admin menu options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{menu} eq 'ARRAY'); + my $output = qq~ +Menu Options (show/hide) + ~; + my $i = 0; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + my ($menu, $url, $enabled) = @$menu_option; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $menu + ~; + $i++; + } + return $output; +} + +sub load_hooks { +# ----------------------------------------------------------------- +# Returns the html to enable/disable hooks. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{hooks} eq 'ARRAY'); + my $output = qq~ +Plugin Hooks (enable/disable) + ~; + my $i = 0; + + foreach my $hook (@{$self->{cfg}->{$plugin}->{hooks}}) { + my ($hookname, $prepost, $action, $enabled) = @$hook; + defined $enabled or ($enabled = 1); + $enabled = $enabled ? ' CHECKED' : ''; + $output .= qq~ + $hookname ($prepost) + ~; + $i++; + } + return $output; +} + +sub load_options { +# ----------------------------------------------------------------- +# Returns the html to enable/disable plugin options. +# + my ($self, $plugin) = @_; + return unless (ref $self->{cfg}->{$plugin}->{user} eq 'ARRAY'); + my $output = qq~ +Plugin Options + ~; + + # This may be changed in the future + require GT::SQL::Display::HTML; + my $HTML = GT::SQL::Display::HTML->new(); + foreach my $option (@{$self->{cfg}->{$plugin}->{user}}) { + my ($name, $val, $ins, $type, $names, $values, $form_size) = @$option; + + $type ||= 'text'; $type = lc( $type ); + my $options = {}; + foreach my $i ( 0 .. $#$names ) { $options->{ $values->[$i] } = $names->[$i]; } + + no strict 'refs'; + my $form_element = $HTML->$type( { name => "user-$name", value => $val, values => $options, def => { form_size => $form_size } } ); + use strict; + + if ($ins) { + $output .= qq~$ins~; + } + + $output .= qq~ + + $name + $form_element + + ~; + +# if ($ins) { +# $output .= qq~$ins~; +# } +# +# $output .= qq~ +# +# $name +# +# +# ~; + } + + return $output; +} + +# ------------------------------------------------------------------------------------------------- # +# Removing Files # +# ------------------------------------------------------------------------------------------------- # + +sub delete { +# ---------------------------------------------------------------- +# Remove a plugin completely from the Uninstalled dir. +# + my $self = shift; + my $plugin_name = $self->{cgi}->param('plugin_name') or return { error => "No plugin name specified!" }; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + return unlink($file) ? { results => "Plugin successfully removed." } : { error => "Unable to remove plugin: $file. Reason: $!" }; +} + +# ------------------------------------------------------------------------------------------------- # +# Downloading Plugins # +# ------------------------------------------------------------------------------------------------- # + +sub download_gossamer { + my $self = shift; + + require GT::WWW; + require GT::Date; + + my $reg_number = $self->{prog_reg}; + my $url = "http://www.gossamer-threads.com/perl/updates/plugin.cgi"; + my $mh = 10; + my $nh = $self->{cgi}->param('nh') || 1; + my $beg = $nh == 1 ? 0 : $mh * ($nh - 1); + my $www = GT::WWW->new( + protocol => 'http', + host => 'www.gossamer-threads.com', + path => '/perl/updates/plugin.cgi', + parameters => [ + product => $self->{prog_name}, + product_version => $self->{prog_ver}, + reg_number => $reg_number, + sb => $self->{cgi}->param('sb') || 'plugin_name', + so => $self->{cgi}->param('so') || 'asc', + $self->{prog_init} ? (init_path => $self->{prog_init}) : (), + ] + ); + my $page = $www->get or return { error => "Unable to contact Gossamer Threads: " . $www->error() . ". Please try again later." }; + my @plugins = split /\n/, $page; + my $status_line = shift @plugins; + my ($status) = $status_line =~ /^# Status: (\w+)$/; + + if ($status ne 'ok') { + if (!$self->{prog_init}) { + # Old products - they only expect a single error tag containing the error message + return { error => "You are not authorized to connect to the plugin server. Please contact support\@gossamer-threads.com for more information and reference status: '$status'." }; + } + else { + # New programs just get the error_code and format their own message in the template. + # Error codes: + # admin_path_mismatch_reset - the stored admin path does not match; it can be reset from the license area + # admin_path_mismatch - the stored admin path does not match; no resets are available + # invalid_product_id - the 'product' provided is unknown by the plugin server + return { error_code => $status }; + } + } + + my $plugin_cfg = do "$self->{plugin_dir}/plugin.cfg" || {}; + my $count = 0; + my $hits = $#plugins + 1; + my (@output, $speedbar, $html); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ +
        + + + + + + + ~; + foreach my $p (@plugins) { + $count++; + next if $nh > 1 and $count < $beg + 1; + + my %row; + ($row{plg_id}, $row{plg_name}, $row{plg_version}, $row{plg_url}, $row{plg_support}, $row{plg_support_url}, $row{plg_language}, $row{plg_updated}, $row{plg_license}, $row{plg_price}, $row{plg_author}, $row{cli_id_fk}, $row{author_name}, $row{plg_description}) = split /\t/, $p; + $row{plg_updated} = GT::Date::date_get($row{plg_updated}, "%ddd%, %mmm% %dd% %yyyy% %hh%:%MM%:%ss%") if $row{plg_updated}; + + my $fetch = "$url/$row{plg_name}.tar?id=$row{plg_id};reg_number=$reg_number"; + $row{download_url} = $self->{cgi}->escape($fetch); + $row{installed} = $plugin_cfg->{$row{plg_name}} ? $plugin_cfg->{$row{plg_name}}->{version} : ''; + push @output, \%row; + + my $price = $row{plg_license} == 2 ? $row{plg_price} : 'Free'; + $output .= qq~ + + + + + + ~; + last if @output == $mh; + } + if ($hits > $mh) { + my $pages = int($hits / $mh); + $pages++ if $hits % $mh; + for my $i (1..$pages) { + $self->{cgi}->param('nh', $i); + my $url = $self->{cgi}->url; + $speedbar .= $i == $nh ? "$i " : "$i "; + } + } + $output = qq~ +

        <$font>There are $hits plugins available for download.

        + $speedbar + $output +
        <$font>Plugin Name<$font>Latest Version<$font>Action
        + <$font>$row{plg_name}
        + Author: $row{author_name}
        + Last Updated: $row{plg_updated}
        + Description:
        $row{plg_description}
        + Price: $price + +
        <$font>$row{plg_version}<$font>Download
        +
        + $speedbar + ~; + return { plugins => \@output, num_plugins => $hits, speedbar => $speedbar, base_url => $self->{base_url}, gossamer => $output }; +} + +sub download_file { +# ------------------------------------------------------------------- +# Place the upload file into the Uninstalled directory. +# + my $self = shift; + my $file = $self->{cgi}->param('file'); + if (! $file) { + return { error => "Please press browse to pick a file before uploading." }; + } + my ($name) = $file =~ m,([^/\\]+)$,; + if ($name !~ /^[\w\-\.]+\.tar$/) { + return { error => "Invalid file name: $name. Must be a .tar file, and only be letters and numbers, no spaces." }; + } + my $full_path = $self->{plugin_dir} . "/Uninstalled/" . $name; + open (FILE, "> $full_path") or return { error => "Unable to create file: $full_path ($!)" }; + binmode FILE; # Output stream + binmode $file; # Input stream + my ($read, $buffer); + while ($read = read($file, $buffer, 4096)) { + print FILE $buffer; + } + close FILE; + + return { results => "File was uploaded successfully." }; +} + +sub download_url { +# ------------------------------------------------------------------- +# Fetch a plugin from a URL and save it to the folder. +# + my $self = shift; + my $url = $self->{cgi}->param('url'); + $url or return { error => "Please enter a valid url." }; + require GT::WWW; + my ($protocol) = GT::WWW->parse_url($url); + return { error => "Invalid URL specified" } unless $protocol; + + unless (GT::WWW->protocol_supported($protocol)) { + return { error => "Unsupported protocol entered: $protocol" }; + } + + my ($fh, $plugin_file, $full_path, $plugin_error, $status_error, $open_error, $no_filename, $print_error); + my $www = GT::WWW->new($url); + $www->chunk_size(16 * 1024); # Get 16KB at a time + $www->chunk(sub { + my $chunk = shift; + unless ($fh or defined $plugin_error) { + my $response = $www->response; + my $status = $response->status; + my $header = $response->header; + if ($status_error = not $status) { + $www->cancel; + return; + } + if ($header->contains('X-Plugins' => 'Error')) { + $plugin_error = ''; + } + else { + $plugin_file = {$header->header_words('Content-Disposition')}->{filename}; + unless ($plugin_file) { + if (!$www->query_string) { + my $path = $www->path; + ($plugin_file) = $path =~ m{/([^/]+)\.tar$}; + $plugin_file .= ".tar" if $plugin_file; + } + unless ($plugin_file) { + $open_error = "No plugin found at url: $url"; + $no_filename = 1; + $www->cancel; + return; + } + } + $fh = \do { local *PLUGIN; *PLUGIN }; + $full_path = "$self->{plugin_dir}/Uninstalled/$plugin_file"; + unless (open $fh, "> $full_path") { + $open_error = "Unable to create file '$full_path': $!"; + $www->cancel; + return; + } + binmode $fh; + } + } + if (defined $plugin_error) { $plugin_error .= $$chunk } + else { + unless (print $fh $$chunk) { + $print_error = "Unable to continue writing to file '$full_path': $!. Removing partial file."; + $www->cancel; + unlink $full_path; + } + } + }); + + my $response = $www->get or return { error => "Unable to retrieve plugin: " . $www->error }; + $status_error and return { error => "Unable to retrieve plugin: Server returned error status: " . (int $response->status) . $response->status }; + defined $plugin_error and return { error => $plugin_error }; + $open_error and return { error => $open_error }; + $print_error and return { error => $print_error }; + + return { results => "Plugin $plugin_file retrieved successfully." }; +} + +# ------------------------------------------------------------------------------------------------- # +# Utilities # +# ------------------------------------------------------------------------------------------------- # + +sub admin_menu { +# ---------------------------------------------------------------- +# Displays the admin menu. +# + my $self = shift; + my $menu = ''; + foreach my $plugin (sort keys %{$self->{cfg}}) { + next unless ($self->{cfg}->{$plugin}->{menu}); + $menu .= qq~ + +  $plugin
        + ~; + foreach my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + next if (defined $menu_option->[2] and ! $menu_option->[2]); + $menu .= qq~  
        $menu_option->[0]
        ~; + } + $menu .= " "; + } + if ($menu) { + $menu = qq~ + +  Installed + Plugins + + $menu + ~; + } + return $menu; +} + +sub admin_menu_items { +# ----------------------------------------------------------------------------- +# Returns tags meant for a template to reproduce the above menu. In +# particular, you get a 'plugin_menus' loop which has a 'plugin_name' key and +# 'plugin_menu' loop; plugin_menu contains two keys - name and url. +# + my $self = shift; + my @plugins; + for my $plugin (sort keys %{$self->{cfg}}) { + next unless $self->{cfg}->{$plugin}->{menu}; + push @plugins, { plugin_name => $plugin }; + for my $menu_option (@{$self->{cfg}->{$plugin}->{menu}}) { + next if defined $menu_option->[2] and not $menu_option->[2]; + push @{$plugins[-1]->{plugin_menu}}, { name => $menu_option->[0], url => $menu_option->[1] }; + } + } + return { plugin_menus => \@plugins }; +} + +sub installed_plugins { +# ---------------------------------------------------------------- +# Returns a list of installed plugins, not formatted. +# + my $self = shift; + my $plgs = {}; + foreach my $plugin (keys %{$self->{cfg}}) { + next if (substr($plugin, 0, 1) eq '_'); + $plgs->{$plugin} = $self->{cfg}->{$plugin}; + } + return $plgs; +} + +sub installed_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of installed plugins. +# + my $self = shift; + my $plugins = $self->installed_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; +# Show installed plugins. + my $base = $self->{base_url}; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Installed Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title<$font>$version<$font>$author<$font>Edit | + Uninstall
        "; + if (! $count) { + $html = "
        No plugins have been installed.
        "; + } + return $html; +} + +sub uninstalled_plugins { +# ---------------------------------------------------------------- +# Returns a list of uninstalled plugins, not formatted. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!); + while (defined(my $file = readdir(DIR))) { + next unless ($file =~ /^(.+)\.tar$/); + my $plugin_name = $1; + my $tar = $self->_open_tar($plugin_name, 'Uninstalled'); + $tar or $plugins{$plugin_name} = { tar_error => $GT::Plugins::error } and next; + my $plugin = $self->_load_plugin_install($tar, $plugin_name); + $plugin or $plugins{$plugin_name} = { inst_error => $GT::Plugins::error } and next; + $plugins{$plugin_name} = $plugin; + } + closedir(DIR); + return \%plugins; +} + +sub uninstalled_plugins_html { +# ---------------------------------------------------------------- +# Returns a formatted string of uninstalled plugins. +# + my $self = shift; + my $plugins = $self->uninstalled_plugins; + my $count = 0; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $html = qq~ +
        + + + + + + + + + + ~; + my $base = $self->{base_url}; + my $func = $self->{func_url} ? $self->{func_url} : "$base&do=plugin"; + foreach my $name (sort keys %$plugins) { + my $plugin = $plugins->{$name}; + my $plugin_e= $self->{cgi}->escape($name); + my $title = $plugin->{meta}->{title} || $name; + my $author = $plugin->{meta}->{author} || 'Unknown Author'; + my $url = $plugin->{meta}->{url} || ''; + my $version = $plugin->{version} || 'Unknown Version'; + my $tar_err = $plugin->{tar_error} || ''; + my $inst_err = $plugin->{inst_error} || ''; + my $inst_l = qq~Install |~; + my $edit_l = qq~Edit |~; + my $error = ''; + if ($tar_err) { + $error = "
        $tar_err"; + $inst_l = ''; + $edit_l = ''; + } + if ($inst_err) { + $error = "
        $inst_err"; + $inst_l = ''; + } + $url and ($author = qq~$author~); + $html .= qq~ + + + + + + + ~; + $count++; + } + $html .= "
        <$font>Uninstalled Plugins
        <$font>Name<$font>Version<$font>Author<$font>Action
        <$font>$title$error<$font>$version<$font>$author<$font>$inst_l $edit_l + Delete + | Download
        "; + if (! $count) { + $html = "
        No plugins are available to be installed.
        "; + } + return $html; +} + +sub uninstalled_plugin_info { +# ---------------------------------------------------------------- +# Returns a hash of plugin info for an uninstalled plugin. +# + my ($self, $plugin_name) = @_; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $plugin_name . ".tar"; + if (! -e $file) { + return $self->error('CANTOPEN', 'WARN', $file, $!); + } + my $tar = GT::Tar->open($file) or return; + my $plugin = $self->_load_plugin_install($tar, $plugin_name) or return; + return $plugin; +} + +sub installed_plugin_info { +# ---------------------------------------------------------------- +# Return a hash of plugin info for an installed plugin. +# + my ($self, $plugin_name) = @_; + return exists $self->{cfg}->{$plugin_name} ? + $self->{cfg}->{$plugin_name} : + $self->error('NOPLUGIN', 'WARN', $plugin_name); +} + +sub _open_tar { +# ---------------------------------------------------------------- +# Opens a tar file. +# + my ($self, $plugin_name, $dir) = @_; + my $file = $self->{plugin_dir} . '/' . $dir . '/' . $plugin_name . '.tar'; + if (! -e $file) { + return $self->error('CANTLOAD', 'WARN', $file, $!); + } + my $tar = GT::Tar->open( $file ) or return $self->error('CANTLOAD', 'WARN', $file, "Unable to parse tar file: $GT::Tar::error"); + return $tar; +} + +sub _load_plugin_install { +# ---------------------------------------------------------------- +# Takes a .tar file, looks for an Install.pm file, evals it, and +# returns a hash of meta info. +# + my ($self, $tar, $plugin_name) = @_; + my $install = $tar->get_file('Install.pm') or return $self->error('CANTLOAD', 'WARN', $plugin_name, "No Install.pm file found in tar!"); + +# Eval the install file. + my $file = $install->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $plugin_name, "Install.pm does not compile: $@"); + } + } + +# Load the meta info. + no strict 'refs'; + my $plugin_pkg = $self->{prefix} . $plugin_name; + $plugin_pkg = 'Plugins::' . $plugin_pkg unless index($plugin_pkg, 'Plugins::') >= 0; + + my $version = ${$plugin_pkg . "::VERSION"}; + + my $meta = defined ${$plugin_pkg . '::META'} ? ${$plugin_pkg . '::META'} : {}; + if (! defined $version) { + $version = defined $meta->{version} ? $meta->{version} : 'UNKNOWN'; + } + my $author = defined $meta->{author} ? $meta->{author} : 'Unknown'; + my $url = defined $meta->{url} ? $meta->{url} : 'Unknown'; + my $desc = defined $meta->{description} ? $meta->{description} : 'None'; + + return { name => $plugin_name, meta => $meta, author => $author, url => $url, description => $desc, version => $version }; +} + +sub _syntax_check { +# ------------------------------------------------------------------- +# Returns the output of syntax checking the current file. +# + my $self = shift; + my $file = shift; + my $results; + + require GT::TempFile; + if ($self->{path_to_perl} and -x $self->{path_to_perl}) { + my $tmp_file = new GT::TempFile; + open (TMPFILE, "> $$tmp_file") or return "Couldn't open temp file: $$tmp_file ($!)"; + print TMPFILE $file->body_as_string; + close TMPFILE; + + my $args = $self->{perl_args} || ''; + +# We are not really running under mod_perl in the spawned perl check. +# DBI will not load if it thinks we are (but aren't). + local($ENV{GATEWAY_INTERFACE}, $ENV{MOD_PERL}); + my $perl_results = `$self->{path_to_perl} $args $$tmp_file 2>&1`; + my $filename = $file->name; + $perl_results =~ s/$$tmp_file/$filename/g; + + $results = "Perl Said:
        $perl_results
        "; + } + else { + $results = "Unable to execute perl: $self->{path_to_perl}"; + } + return $results; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Wizard.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Wizard.pm new file mode 100644 index 0000000..a1447a6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Plugins/Wizard.pm @@ -0,0 +1,1098 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Plugins +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Wizard.pm,v 1.34 2005/04/14 07:43:48 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: A web based admin to install/uninstall/edit plugins. +# + +package GT::Plugins::Wizard; +# ================================================================== +use strict; +use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/; +use GT::Base; +use GT::Plugins; +use GT::Tar; +use GT::Dumper; + +$ERROR_MESSAGE = 'GT::Plugins'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/; +$ATTRIBS = { + prefix => '', + cgi => undef, + initial_indent => ' ', + tpl_root => '.', + tpl_prefix => '', + plugin_dir => undef, + plugin => undef, + tar => undef, + prog_ver => undef, + install_header => undef, + dirs => {}, + oo => undef +}; +@ISA = qw/GT::Base/; + +sub process { +# ---------------------------------------------------------------- +# Determines what to do based on cgi input, and return a hash +# content => data for printing by outside application. +# + my $self = shift; + ref $self->{cgi} and UNIVERSAL::can($self->{cgi}, 'param') or return $self->error('BADARGS', 'FATAL', "no cgi object passed to wizard"); + defined $self->{plugin_dir} and -d $self->{plugin_dir} or return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to wizard"); + +# Figure out what to do. + my $action = $self->{cgi}->param('plugin_wiz_do') || ''; + my $vars = {}; + my $page = 'plugin_wizard_step1.html'; + my $plugin = $self->{cgi}->param('plugin_name'); + $self->load_plugin($plugin) if ($plugin); + + CASE: { +# Meta Information + ($action eq 'step2') and do { + $vars = $self->_validate_step1(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step1.html'; last CASE } + $vars = $self->_load_step2(); + $page = 'plugin_wizard_step2.html'; + last CASE; + }; +# Plugin Hooks + ($action eq 'step3') and do { + $vars = $self->_validate_step2() unless ($self->{cgi}->param('skip_validate')); + if (defined $vars->{error}) { $page = 'plugin_wizard_step2.html'; last CASE } + $vars = $self->_load_step3(); + $page = 'plugin_wizard_step3.html'; + last CASE; + }; +# Admin Menu Options. + ($action eq 'step4') and do { + $vars = $self->_validate_step3(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step3.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step3.html'; last CASE } + $vars = $self->_load_step4(); + $page = 'plugin_wizard_step4.html'; + last CASE; + }; +# User Options. + ($action eq 'step5') and do { + $vars = $self->_validate_step4(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step4.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step4.html'; last CASE } + $vars = $self->_load_step5(); + $page = 'plugin_wizard_step5.html'; + last CASE; + }; +# Included Files. + ($action eq 'step6') and do { + $vars = $self->_validate_step5(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step5.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step5.html'; last CASE } + $vars = $self->_load_step6(); + $page = 'plugin_wizard_step6.html'; + last CASE; + }; +# All Done. + ($action eq 'step7') and do { + $vars = $self->_validate_step6(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step6.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step6.html'; last CASE } + $vars = $self->_load_step7(); + $page = 'plugin_wizard_step7.html'; + last CASE; + }; +# Create the plugin and finish. + ($action eq 'create') and do { + $vars = $self->_validate_step7(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_install(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $vars = $self->_create_code(); + if (defined $vars->{error}) { $page = 'plugin_wizard_step7.html'; last CASE } + if (defined $vars->{results}) { $page = 'plugin_wizard_step7.html'; last CASE } + $page = 'plugin_wizard_step8.html'; + last CASE; + }; + +# Get a list of plugins that can be edited. + $vars->{edit} = $self->_list_editable; + } + + return $self->page($page, $vars); +} + +sub page { +# ---------------------------------------------------------------- +# Returns a content => parsed_page hash ref. +# + my ($self, $page, $vars) = @_; + my $cgi = $self->{cgi}->get_hash; + for my $key (keys %$cgi) { exists $vars->{$key} or $vars->{$key} = $cgi->{$key}; } + my $contents = GT::Template->parse( + $self->{tpl_prefix} . $page, + $vars, + { root => $self->{tpl_root} } + ) or return; + return { content => \$contents }; +} + +sub load_plugin { +# ---------------------------------------------------------------- +# Loads a plugin. +# + my ($self, $plugin_name) = @_; + $self->{plugin}->{name} = $plugin_name; + return unless (defined $plugin_name and $plugin_name =~ /^\w{2,20}$/); + + $self->{tar} = $self->_load_tar; + $self->_load_plugin; + return 1; +} + +sub save_plugin { +# ------------------------------------------------------------------- +# Saves the plugin back to disk. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm'); + if (! $wizard) { + $self->{tar}->add_data(name => 'Wizard.pm', body => $self->_create_wizard); + } + else { + $wizard->body($self->_create_wizard); + } + return $self->{tar}->write; +} + +sub _get_hook_params { +# ------------------------------------------------------------------------------ + my $hook = shift; + my $param = shift; + my %results; + for my $e (@$hook) { + my $val = ref $e->{$param} ? join(", ", @{$e->{$param}}) : $e->{$param}; + $results{$val}++; + } + return sort keys %results; +} + +sub _validate_step1 { +# ------------------------------------------------------------------- +# Checks that the plugin name is valid. +# + my $self = shift; + my $name = $self->{cgi}->param('plugin_name'); + $name or return { error => "Please enter a valid plugin name." }; + $name =~ /^\w{2,20}$/ or return { + error => "Plugin names must be only letters and numbers, and be between 2 and 20 characters." + }; + $self->save_plugin or return { error => $GT::Plugins::error }; + return { plugin_name => $name }; +} + +sub _load_step2 { +# ------------------------------------------------------------------- +# Preloads vars for meta information. +# + my $self = shift; + return defined $self->{plugin}->{meta}->{prog_ver} + ? $self->{plugin}->{meta} + : { %{$self->{plugin}->{meta}}, prog_ver => $self->{prog_ver} }; +} + +sub _validate_step2 { +# ------------------------------------------------------------------- +# Validates the meta information. +# + my $self = shift; + my $version = $self->{cgi}->param('version'); + $version or return { error => "Please make sure you enter a version, perhaps start with 0.0.1 to begin." }; + $version =~ /^[\d\.]+$/ or return { error => "Version numbers should contain only numbers and periods." }; + + my $author = $self->{cgi}->param('author'); + $author or return { error => "Please make sure you enter an author." }; + + my $url = $self->{cgi}->param('url'); + + my $license = $self->{cgi}->param('license'); + $license or return { error => "Please make sure you enter in a license style." }; + + my $prog_ver = $self->{cgi}->param('prog_ver'); + $prog_ver or return { + error => 'Please enter a program version that your plugin will require. Set to 1 for all versions. ' . + 'This is useful to ensure the plugin user has the required version before using the plugin.' + }; + + my $description = $self->{cgi}->param('description'); + + $self->{plugin}->{meta} = { + version => $version, + author => $author, + url => $url, + license => $license, + description => $description, + prog_ver => $prog_ver + }; + + $self->save_plugin or return { error => $GT::Plugins::error }; + + return {}; +} + +sub _load_step3 { +# ------------------------------------------------------------------- +# Preloads vars for hook information. +# + my $self = shift; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + +# try to load the hook config file + return { hooks => '' } unless defined $self->{plugin}->{hooks} and @{$self->{plugin}->{hooks}}; + + my $output = qq~ + + + + + + ~; + + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + my ($name, $type, $code, $position) = @$hook; + $output .= qq~ + + + + + + ~; + } + $output .= qq~ +
        <$font>Hook<$font>Type<$font>Code<$font>Position
        <$font> $name<$font>$type<$font>$code<$font>$position
        + ~; + return { hooks => $output }; +} + +sub _validate_step3 { +# ------------------------------------------------------------------- +# Validate any new hooks that were added. +# + my $self = shift; + $self->{plugin}->{hooks} ||= []; + +# Remove unwanted hooks. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $id = join("|", @$hook); + if ($id eq $del_id) { + $results .= "
      • Plugin hook " . $hook->[0] . " successfully removed."; + splice @{$self->{plugin}->{hooks}}, $i, 1; + } + $i++; + } + } + } +# Add new hooks + my $add_hook = $self->{cgi}->param('name'); + if ($add_hook) { + my $add_code = $self->{cgi}->param('code'); + my $add_type = $self->{cgi}->param('type'); + my $add_pos = $self->{cgi}->param('pos'); # Not used; future use? + push @{$self->{plugin}->{hooks}}, [$add_hook, $add_type, $add_code, $add_pos]; + $results .= "
      • Plugin hook $add_hook successfully added."; + } + my $hooks = $self->_load_step3; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", hooks => $hooks->{hooks} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more hooks to delete.", hooks => $hooks->{hooks} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, hooks => $hooks->{hooks} }; + } + return {}; +} + +sub _load_step4 { +# ------------------------------------------------------------------- +# Preloads vars for admin menu options. +# + my $self = shift; + return { menu => '' } unless $self->{plugin}->{menu} and @{$self->{plugin}->{menu}}; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Name<$font>URL
        <$font> $name<$font>$url
        + ~; + return { menu => $output }; +} + +sub _validate_step4 { +# ------------------------------------------------------------------- +# Validate any new menu that were added. +# + my $self = shift; + $self->{plugin}->{menu} ||= []; + +# Remove unwanted menu. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $menu (@{$self->{plugin}->{menu}}) { + my ($name, $url) = @$menu; + if ($name eq $del_id) { + splice @{$self->{plugin}->{menu}}, $i, 1; + $results .= "
      • Menu Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new menu + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_url = $self->{cgi}->param('url'); + $self->{plugin}->{menu} ||= []; + push @{$self->{plugin}->{menu}}, [$add_name, $add_url]; + $results .= "
      • Menu Option $add_name successfully added."; + } + + my $menu = $self->_load_step4; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", menu => $menu->{menu} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more admin menu to delete.", menu => $menu->{menu} }; + } + + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, menu => $menu->{menu} }; + } + return {}; +} + +sub _load_step5 { +# ------------------------------------------------------------------- +# Preloads vars for user options. +# + my $self = shift; + return { user => '' } unless (defined $self->{plugin}->{user} and @{$self->{plugin}->{user}}); + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + + + + + ~; + + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $instructions, $form_type, $form_names, $form_values ) = @$opt; + $form_values = @$form_values + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_values) . "
        " + : " "; + $form_names = @$form_names + ? "
          " . join("", map { "
        • " . $self->{cgi}->html_escape($_) . "
        • " } @$form_names) . "
        " + : " "; + my $ins = $self->{cgi}->html_escape($instructions); + $val = $self->{cgi}->html_escape($val); + $output .= qq~ + + + + + + + + +~; + } + $output .= qq~
        <$font>Name<$font>Value<$font>Instructions<$font>Form Type<$font>Form Names<$font>Form Value
        <$font> $name<$font>$val<$font>$ins <$font>$form_type<$font>$form_names<$font>$form_values
        ~; + + return { user => $output }; +} + +sub _validate_step5 { +# ------------------------------------------------------------------- +# Validate any user options that were added. +# + my $self = shift; + $self->{plugin}->{user} ||= []; + +# Remove unwanted user options. + my $results = ''; + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $opt (@{$self->{plugin}->{user}}) { + my ($name, $val, $ins) = @$opt; + if ($name eq $del_id) { + splice @{$self->{plugin}->{user}}, $i, 1; + $results .= "
      • User Option " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add new user option + my $add_name = $self->{cgi}->param('name'); + if ($add_name) { + my $add_val = $self->{cgi}->param('value'); + my $add_ins = $self->{cgi}->param('instructions'); + my $form_names = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_names') ]; + my $form_values = [ grep $_, split /(?:\r|\n)+/, $self->{cgi}->param('form_values') ]; + my $form_type = $self->{cgi}->param('form_type'); + push @{$self->{plugin}->{user}}, [ $add_name, $add_val, $add_ins, $form_type, $form_names, $form_values ]; + $results .= "
      • User Option $add_name successfully added."; + } + my $user = $self->_load_step5; + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", user => $user->{user} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more user option to delete.", user => $user->{user} }; + } + $self->save_plugin or return { error => $GT::Plugins::error }; + if ($results) { + return { results => $results, user => $user->{user} }; + } + return {}; +} + +sub _load_step6 { +# ------------------------------------------------------------------- +# Preloads any user included files. +# + my $self = shift; + return { files => '' } unless (defined $self->{plugin}->{files} and @{$self->{plugin}->{files}}); + + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + my $output = qq~ + + + + ~; + + my %seen; + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $location) = @$file; + my $id = join("|", @$file); + next if $name eq "$self->{plugin}->{name}.pm"; + if (exists $self->{dirs}->{$location}) { + $location = $self->{dirs}->{$location}; + } + $seen{$name}++; + $output .= qq~ + + + + ~; + } + my $files = $self->{tar}->files; + for my $file (@$files) { + my $name = $file->name; + my $id = $name . '|'; + + next if $seen{$name} or $name eq 'Wizard.pm' or $name eq 'Install.pm' or $name eq "$self->{plugin}->{name}.pm"; + + push @{$self->{plugin}->{files}}, [$name, '']; + $output .= qq~ + + + + ~; + } + $output .= qq~ +
        <$font>Filename<$font>Location
        <$font> $name<$font>$location
        <$font> $name<$font>Unknown (not added in Wizard)
        + ~; + return { files => $output }; +} + +sub _validate_step6 { +# ------------------------------------------------------------------- +# Receives files and stores them in the tar file. +# + my $self = shift; + my $results = ''; + $self->{plugin}->{files} ||= []; + +# Remove any existing files. + if ($self->{cgi}->param('delete_btn')) { + my @to_delete = $self->{cgi}->param('delete'); + for my $del_id (@to_delete) { + my $i = 0; + for my $file (@{$self->{plugin}->{files}}) { + my $id = join("|", @$file); + if ($id eq $del_id) { + my $name = $file->[0]; + $self->{tar}->remove_file($name); + $self->{tar}->write; + splice @{$self->{plugin}->{files}}, $i, 1; + $results .= "
      • File " . $name . " successfully removed."; + } + $i++; + } + } + } + +# Add any new attachments. + my $filename = $self->{cgi}->param('name'); + if ($filename) { + my $filehandle = $self->{cgi}->param('file'); + my $body = $self->{cgi}->param('add_body'); + my $location = $self->{cgi}->param('location'); + if (ref $filehandle) { + $body = ''; + my ($buffer, $read); + while ($read = read($filehandle, $buffer, 4096)) { + $body .= $buffer; + } + } + $body ||= ' '; + $body =~ s/\r//g; + push @{$self->{plugin}->{files}}, [$filename, $location]; + my $res = $self->{tar}->add_data(name => $filename, body => $body); + $results .= "File $filename attached successfully."; + } + my $file = $self->_load_step6; + $self->save_plugin or return { error => $GT::Plugins::error }; + + if (! $results and $self->{cgi}->param('add_btn')) { + return { error => "Please fill out the add form completely.", files => $file->{files} }; + } + if (! $results and $self->{cgi}->param('delete_btn')) { + return { error => "Please select one or more file to delete.", files => $file->{files} }; + } + if ($results) { + return { results => $results, files => $file->{files} }; + } + return {}; +} + +sub _load_step7 { +# ------------------------------------------------------------------- +# Fetches the install/uninstall message. +# + my $self = shift; + return { + install => $self->{plugin}->{install}, + uninstall => $self->{plugin}->{uninstall}, + install_code => $self->{plugin}->{install_code}, + uninstall_code => $self->{plugin}->{uninstall_code} + }; +} + +sub _validate_step7 { +# ------------------------------------------------------------------- +# Saves the install/uninstall message. +# + my $self = shift; + $self->{plugin}->{install} = $self->{cgi}->param('install'); + $self->{plugin}->{uninstall} = $self->{cgi}->param('uninstall'); + $self->{plugin}->{install_code} = $self->{cgi}->param('install_code'); + $self->{plugin}->{uninstall_code} = $self->{cgi}->param('uninstall_code'); + $self->save_plugin or return { error => $GT::Plugins::error }; + return {}; +} + +sub _create_code { +# ------------------------------------------------------------------- +# Creates the code file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + $self->{install_header} ||= ''; + my $stubs = $self->_create_stubs; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== + +$self->{initial_indent}use strict; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +# Inherit from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +# Your code begins here. +$stubs + +# Always end with a 1. +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file($self->{plugin}->{name} . '.pm'); + if ($file) { + my $overwrite = $self->{cgi}->param('overwrite'); + my $skip = $self->{cgi}->param('skip'); + if (! $overwrite and ! $skip) { + return { error => "Overwrite the existing $self->{plugin}->{name}.pm:
        " }; + } + $file->body($output) if ($overwrite); + } + else { + $self->{tar}->add_data( name => $self->{plugin}->{name} . '.pm', body => $output ); + } + $self->{tar}->write; + return {}; +} + +sub _create_install { +# ------------------------------------------------------------------- +# Creates the install.pm file. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $version = $self->{plugin}->{meta}->{version} || 0; + (my $qversion = $version) =~ s/(?=['\\])/\\/g; + + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{plugin}->{meta}); + my $inst_mess = GT::Dumper->dump(var => 'my $inst_msg', data => $self->{plugin}->{install}); + my $uninst_mess = GT::Dumper->dump(var => 'my $uninst_msg', data => $self->{plugin}->{uninstall}); + my $install = $self->_create_install_func; + my $uninstall = $self->_create_uninstall_func; + + for ($meta_dump, $inst_mess, $uninst_mess, $install, $uninstall) { s/\r//g } + + my $inst_code = $self->{plugin}->{install_code} || ''; + $inst_code =~ s/\r//g; + $inst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + my $uninst_code = $self->{plugin}->{uninstall_code} || ''; + $uninst_code =~ s/\r//g; + $uninst_code =~ s/;?$/;/; # Not ending a statement with a ; is valid Perl; handle it here. + $self->{install_header} ||= ''; + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{plugin}->{meta}->{author} +# Version : $version +# Updated : $time +# +# ================================================================== +# + +package $plugin_pkg; +# ================================================================== +$self->{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$VERSION \$DEBUG \$NAME \$META/; +$self->{initial_indent}use GT::Base; +$self->{initial_indent}use GT::Plugins qw/STOP CONTINUE/; +$self->{initial_indent}$self->{install_header} + +$self->{initial_indent}\$VERSION = '$qversion'; +$self->{initial_indent}\$DEBUG = 0; +$self->{initial_indent}\$NAME = '$self->{plugin}->{name}'; +# Inhert from base class for debug and error methods +$self->{initial_indent}\@${plugin_pkg}::ISA = qw(GT::Base); + +$self->{initial_indent}$meta_dump + +sub pre_install { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they install the plugin. +# + $inst_mess + return \$inst_msg; +} + +sub pre_uninstall { +# ----------------------------------------------------------------------------- +# This function displays an HTML formatted message that will display any +# instructions/information to the user before they remove the plugin. +# + $uninst_mess + return \$uninst_msg; +} + +sub install { +# ----------------------------------------------------------------------------- +# This function does the actual installation. Its first argument is a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. The second argument is a GT::Tar object which you can use to access any +# files in your plugin module. +# +# You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$Plugins::$self->{prefix}$self->{plugin}->{name}::error +# + my (\$mgr, \$tar) = \@_; + $install + $inst_code + return "The plugin has been successfully installed!"; +} + +sub uninstall { +# ----------------------------------------------------------------------------- +# This function removes the plugin. Its first argument is also a plugin +# manager which you can use to register hooks, install files, add menu options, +# etc. You should return an HTML formatted string that will be displayed to the +# user. +# +# If there is an error, return undef, and set the error message in +# \$${plugin_pkg}::error +# + my \$mgr = shift; + $uninstall + $uninst_code + return "The plugin has been successfully removed!"; +} + +1; +END_OF_PLUGIN + my $file = $self->{tar}->get_file('Install.pm'); + if ($file) { + $file->body($output); + } + else { + $self->{tar}->add_data(name => 'Install.pm', body => $output); + } + $self->{tar}->write; + return {}; +} + +sub _esc { +# ------------------------------------------------------------------- + $_[0] =~ s/'/\\'/g; + $_[0] =~ s/\n/\\\n/g; + $_[0] =~ s/\r//g; + return; +} + +sub _create_install_func { +# ------------------------------------------------------------------- +# Creates the install function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + + $code .= qq~\n \$mgr->install_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~\n \$mgr->install_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + $code .= qq~\n \$mgr->install_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + if (@{$self->{plugin}->{files}}) { + $code .= qq~ + +# Silence warnings + \$GT::Tar::error ||= ''; + +# The following section will unarchive attached files into the proper location. + my \$file;~; + } + for my $file (@{$self->{plugin}->{files}}) { + my ($name, $loc) = @$file; + next if ($name eq $self->{plugin}->{name} . '.pm'); + next if ($name eq 'Install.pm'); + my $path = ''; + if (exists $self->{dirs}->{$loc}) { + $path = $self->{dirs}->{$loc}; + } + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + $code .= qq~ + +# Copying $name to $path directory. + \$file = \$tar->get_file('$name'); + \$file->name("$path/$name"); + \$file->write or return $plugin_pkg->error("Unable to extract file '$path/$name': \$GT::Tar::error", 'WARN');~; + } + return $code; +} + +sub _create_uninstall_func { +# ------------------------------------------------------------------- +# Creates the uninstall function based on everything we know. +# + my $self = shift; + my $code = ''; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $val1 = $hook->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $hook->[1]; $val2 =~ s/'/\\'/g; + my $val3 = $hook->[2]; $val3 =~ s/'/\\'/g; + my $val4 = $hook->[3]; + $code .= qq~\n \$mgr->uninstall_hooks('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4']]);~; + } + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $menu->[1]; $val2 =~ s/'/\\'/g; + $code .= qq~ \$mgr->uninstall_menu('$self->{plugin}->{name}', [['$val1', '$val2']]);~; + } + for my $user (@{$self->{plugin}->{user}}) { + my $val1 = $user->[0]; $val1 =~ s/'/\\'/g; + my $val2 = $user->[1]; _esc($val2); + my $val3 = $user->[2]; _esc($val3); + my $val4 = $user->[3]; _esc($val4); + require GT::Dumper; + my $val5 = GT::Dumper->dump(var => '', data => $user->[4], compress => 1 ); $val5 =~ s/;$//; + my $val6 = GT::Dumper->dump(var => '', data => $user->[5], compress => 1 ); $val6 =~ s/;$//; + my $val7 = $user->[6]; _esc($val7); + + $code .= qq~\n \$mgr->uninstall_options('$self->{plugin}->{name}', [['$val1', '$val2', '$val3', '$val4', $val5, $val6, '$val7']]);~; + } + return $code; +} + +sub _create_stubs { +# ------------------------------------------------------------------- +# Creates a subroutine stub for each hook. +# + my $self = shift; + my $code = ''; + if (@{$self->{plugin}->{hooks}}) { + $code .= qq~ + +# PLUGIN HOOKS +# =================================================================== +~; + } + my %seen; + for my $hook (@{$self->{plugin}->{hooks}}) { + my $full_sub_name = $hook->[2]; + my ($sub_name) = $full_sub_name =~ /([^:]+)$/; + next if $seen{$sub_name}++; + my $hook_name = $hook->[0]; + $code .= qq~ + +sub $sub_name { +# ----------------------------------------------------------------------------- +# This subroutine will be called whenever the hook '$hook_name' is run. You +# should call @{[$self->{oo} || 'GT::Plugins']}->action(STOP) if you don't want the regular +# '$hook_name' code to run, otherwise the code will continue as normal. +# + my (\@args) = \@_; + +# Do something useful here + + return \@args; +}~; + } + if (@{$self->{plugin}->{menu}}) { + $code .= qq~ + +# ADMIN MENU OPTIONS +# =================================================================== +~; + } + %seen = (); + for my $menu (@{$self->{plugin}->{menu}}) { + my $val1 = $menu->[0]; + my $val2 = $menu->[1]; + my ($func) = $val2 =~ /func=(\w+)/; + next if $seen{$func}++; + if ($func) { + $code .= qq~ +sub $func { +# ------------------------------------------------------------------- +# This subroutine will be called whenever the user clicks on '$val1' in the +# admin menu. Remember, you need to print your own HTTP header; to do so you +# can use: +# +# print \$IN->header(); +# + +}~; + } + } + return $code; +} + +sub _create_wizard { +# ------------------------------------------------------------------- +# Creates the Wizard.pm file which is used to load wizard information. +# + my $self = shift; + my $output = ''; + my $time = localtime(); + my $author = $self->{plugin}->{meta}->{author} || ''; + my $version = $self->{plugin}->{meta}->{version} || ''; + my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta}); + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + $output = <{initial_indent}use strict; +$self->{initial_indent}use vars qw/\$WIZARD/; + +END_OF_PLUGIN + $output .= GT::Dumper->dump(var => '$WIZARD', data => $self->{plugin}); + $output .= "\n\n1;\n"; + return $output; +} + +sub _load_tar { +# ------------------------------------------------------------------- +# Loads a tar file. +# + my $self = shift; + my $file = $self->{plugin_dir} . "/Uninstalled/" . $self->{plugin}->{name} . ".tar"; + if (-e $file) { + $self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } + else { + $self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'FATAL', $file, $GT::Tar::error); + } +} + +sub _load_plugin { +# ------------------------------------------------------------------- +# Loads the meta information into self. +# + my $self = shift; + my $wizard = $self->{tar}->get_file('Wizard.pm') + or return $self->error('CANTLOAD', 'WARN', $self->{plugin}->{name}, "No Wizard.pm file found in tar!"); + +# Eval the install file. + my $file = $wizard->body_as_string; + { + local ($@, $SIG{__DIE__}, $^W); + eval "$file"; + if ($@) { + return $self->error('CANTLOAD', 'WARN', $file, "Wizard.pm does not compile: $@"); + } + } + +# Load the information. + + my $plugin_pkg = $self->{prefix} . $self->{plugin}->{name}; + if (index($plugin_pkg, 'Plugins::') < 0) { + $plugin_pkg = 'Plugins::' . $plugin_pkg; + } + + my $var = $plugin_pkg . "::WIZARD"; + { + no strict 'refs'; + $self->{plugin} = $$var; + } + + return 1; +} + +sub _list_editable { +# ------------------------------------------------------------------- +# Returns a select list of plugins that can be edited by the wizard. +# + my $self = shift; + my $dir = $self->{plugin_dir} . '/Uninstalled'; + my %plugins; + my $count = 0; + my $select = ""; + return $count ? $select : ''; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/RDF.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/RDF.pm new file mode 100644 index 0000000..754230e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/RDF.pm @@ -0,0 +1,155 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::RDF +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $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).*?]*?>),$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; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL.pm new file mode 100644 index 0000000..44aaa69 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL.pm @@ -0,0 +1,716 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL +# CVS Info : 087,071,086,086,085 +# $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt 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.112 $ =~ /(\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'", + FKMISSING => "The '%s' table has a relationship with the '%s' table, but the foreign key information from the '%s' table is missing.", + 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.112 $ +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 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 0> or C 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 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 + + $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. 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. + +=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 name. + +=item PREFIX + +This specifies a prefix to use for table names. See the L +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 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 is the name of the table you wish to create. See +L 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 is the name of the table you wish the modify. See +L 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 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 to the beginning of every +table name. This means anywhere you access the table C, the actual table +stored on the SQL server will be C. Note that the prefix should B +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 + +L + +L + +L + +L + +L + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Admin.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Admin.pm new file mode 100644 index 0000000..8af50f9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Admin.pm @@ -0,0 +1,2994 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Admin +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Admin.pm,v 1.161 2009/05/11 22:57:15 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Used to create a basic admin area for the most common admin +# setup. For anything more complex use the Display modules +# individually. This also proves an excelent example of +# how to use the HTML module. +# + +package GT::SQL::Admin; +# =================================================================== +use strict; +use GT::Base; +use GT::AutoLoader; +use GT::CGI; +use GT::SQL; +use GT::SQL::Display::HTML; + +use vars qw/ + @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS + $BAR_COLOR $BAR_FONT $TITLE_FONT $FONT $BODY + $ROW_COLOR1 $ROW_COLOR2 %ACTION +/; + +# Possible arguments to new +$ATTRIBS = { + header => undef, + footer => undef, + start_form => undef, + end_form => undef, + start_html => undef, + end_html => undef, + record => undef +}; + +# Error messages are stored in GT::SQL. +@ISA = qw/GT::Base/; +$ERROR_MESSAGE = 'GT::SQL'; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.161 $ =~ /(\d+)\.(\d+)/; + +# Some default HTML attributes. +$BODY = 'bgcolor="#FFFFFF"'; +$BAR_COLOR = 'navy'; +$BAR_FONT = "face='Arial' size='2' color='#FFFFFF'"; +$TITLE_FONT = "face='Arial' size='2' color='#000000'"; +$FONT = "face='Tahoma,Arial,Helvetica' size='2' color='#000000'"; +$ROW_COLOR1 = 'bgcolor="#dddddd"'; +$ROW_COLOR2 = 'bgcolor="#eeeeee"'; + +%ACTION = ( + add_form => 1, + add_record => 1, + add_success => 1, + delete_records => 1, + delete_results => 1, + delete_search_form => 1, + delete_search_results => 1, + download_file => 1, + edit_table_def => 1, + editor_add_field => 1, + editor_add_field_form => 1, + editor_column_checks => 1, + editor_column_form => 1, + editor_column_help => 1, + editor_columns => 1, + editor_delete_field => 1, + editor_delete_field_form => 1, + editor_export_data => 1, + editor_export_data_form => 1, + editor_import_data => 1, + editor_import_data_form => 1, + editor_modify_columns => 1, + editor_table_form => 1, + editor_update_def => 1, + modify_error => 1, + modify_form => 1, + modify_multi_records => 1, + modify_multi_results => 1, + modify_multi_search_results => 1, + modify_record => 1, + modify_search_form => 1, + modify_search_results => 1, + modify_success => 1, + search_form => 1, + search_results => 1, + view_file => 1 +); + +# ================================================================================ # +# SIMPLE INTERFACE # +# ================================================================================ # + +## +# $obj->process($defs, $in); +# -------------------- +# $defs must be the full path to the directory +# the definition file GT::SQL created. +# $in is a cgi object. This will process +# the cgi object from the forms it created. +# The proper changes will then be made and the +# results shown to the user. +# You should call this after testing to see if +# the input from the cgi is for_me. +## +sub process { + my $self = shift; + $self->initialize(@_) or return; + +# Find out what we are doing. + my $action = $self->{cgi}->{do}; + if (exists $ACTION{$action}) { + $self->$action(); +# print "

        QUERY STACK: ", GT::SQL->query_stack_disp, "
        "; # if ($self->{_debug}); + } + else { +# ERROR they should have called for_me to see if there was an action for me :) + return $self->error('NOACTION', 'FATAL', $action); + } +} + +sub initialize { + my ($self, @in) = @_; + +# Find out what we have, and store the CGI values in self->{cgi}. + my $opt = $self->common_param(@in) or return $self->error("BADARGS", 'FATAL', '$obj->process($in) where $in is a CGI object'); + $self->{in} = $opt->{cgi}; + $self->{cgi} = $self->common_param($opt->{cgi}) or return $self->error("BADARGS", 'FATAL', "You must pass in a cgi object"); + + my $tbl_names = ($self->{cgi}->{db}) || ($opt->{tables}) || (return $self->error('BADARGS', 'FATAL', 'No table passed in via CGI or tables method')); + ref($tbl_names) || ($tbl_names = [ $tbl_names ]); + + if ($opt->{def_path}) { + return $self->error(BADARGS => FATAL => "The 'def_path' argument to \$admin->process is deprecated. You should pass in a GT::SQL object using 'db' instead."); + } + $self->{db} = $opt->{db} or return $self->error('BADARGS', 'FATAL', 'Error: You must pass in a GT::SQL object.'); + $self->{table} = $self->{db}->table(@$tbl_names) or return; + +# Get the name of this table. + my $prefix = $self->{db}->prefix; + if (length $prefix) { + $self->{record} ||= join(',', map { s/^$prefix//; $_; } $self->{table}->name); + } + else { + $self->{record} ||= join(',', $self->{table}->name); + } + +# Get the Display object. + if ($opt->{display}) { + $self->{html} = $opt->{display}; + } + else { + $self->{html} = $self->{db}->html($self->{table}, $self->{cgi}); + } + $self->{html}->{url} = GT::CGI->url(remove_empty => 1); + +# Set any attributes the user passed in to process. + foreach my $option (keys %{$ATTRIBS}) { + $self->{$option} = $opt->{$option} if (exists $opt->{$option}); + } + return 1; +} + +sub preserve { + my $self = shift; + if (@_) { + my $preserve = shift; + $self->{preserve} = $preserve; + } + return $self->{preserve}; +} + +## +# GT::SQL::Admin->for_me($in); +# ---------------------------- +# $in is a cgi object. You should call this in +# an if to see if the cgi object is from a form +# this module produced. +## +sub for_me { + my ($self, @in) = @_; + +# Get options + my $opt = $self->common_param(@in) or return $self->error("BADARGS", 'FATAL', 'GT::SQL::Admin->for_me($in) where $in is a CGI object'); + +# There is no action so return false + $opt->{do} or return 0; + $opt->{db} or return 0; + +# Check to see if there is a routine in this module. + return exists $ACTION{$opt->{do}}; +} + +# Make sure AUTOLOAD does not catch destroyed objects. +sub DESTROY {} + +# ================================================================================ # +# FILE HANDLING # +# ================================================================================ # + +$COMPILE{download_file} = __LINE__ . <<'END_OF_SUB'; +sub download_file { + my ($self, $inline) = @_; + my $in = $self->{in}; + + my $table_name = $in->param('db'); + my $id = $in->param('id'); + my $cn = $in->param('cn'); + my $src = $in->param('src') || 'db'; + my $fname = $in->param('fname'); + + unless ($table_name and $id and $cn) { + print $in->header(); + print $self->_start_html({ title => 'Error Downloading' }); + print $self->_header("Unknown Document Reference", $@); + print $self->_end_html; + return; + } + + my $tbl = $self->{table}; + my ($fh, $size, $mimetype); + if ($src eq 'db') { + eval { $fh = $tbl->file_info($cn, $id) }; + if ($fh) { + $fname = $fh->File_Name(); + $mimetype = $fh->File_MimeType(); + $size = $fh->File_Size(); + } + } + else { + require GT::SQL::File; + eval { $fh = GT::SQL::File->open($fname) }; + $size = -s $fname; + $fname = GT::SQL::File->get_filename($fname); + } + + if (!$fh) { + print $in->header(); + print $self->_start_html({ title => 'Error Downloading' }); + print $self->_header("Error Downloading File", $@ || "Cannot find file pointed to by ID: $id and Column: $cn"); + print $self->_end_html; + } + else { + print $self->{in}->header( + $self->{in}->file_headers( + filename => $fname, + size => $size, + $inline ? () : (inline => 0) + ) + ); + + $fh->File_Binary() and binmode STDOUT; + + while (read($fh, my $buffer, 4096)) { + print $buffer; + } + } +} +END_OF_SUB + + +sub view_file { + my $self = shift; + $self->download_file(1); +} + + +# ================================================================================ # +# SEARCHING RECORDS # +# ================================================================================ # + +$COMPILE{search_form} = __LINE__ . <<'END_OF_SUB'; +sub search_form { + my ($self, $msg) = @_; + $msg &&= qq|$msg|; + + print $self->{in}->header; + print $self->_start_html({ title => "Search Form" }); + print $self->_header("Search Form", $msg || "Search the database to view records."); + print $self->_start_form({ do => "search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'search_form', search_opts => 1, file_browse => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->search_results; +# --------------------- +# Produces the search results for the user to view. +## +$COMPILE{search_results} = __LINE__ . <<'END_OF_SUB'; +sub search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->search_form("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}); + my $hits = $self->{table}->hits(); + if ($hits == 0) { + return $self->search_form("Your search did not match any records."); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + my $name = GT::CGI->url(remove_empty => 1); + if ($hits > ($self->{cgi}->{mh} || 25)) { + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + + if ($self->{in}->param('dr') and $self->{in}->param('dr') eq 'rows') { + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + my $i = 0; + while (my $result = $sth->fetchrow_hashref) { + print "", $self->{html}->display_row({ mode => 'search_results', values => $result }), ""; + } + print "
        "; + } + + else { + while (my $result = $sth->fetchrow_hashref) { + print "

        ", $self->{html}->display({ mode => 'search_results', values => $result }); + } + } + + print $speedbar if ($speedbar); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# ADD RECORDS # +# ================================================================================ # + +## +# $obj->add_form; +# --------------- +# This will print the add form for the current +# tables that we are working with. All the +# options that were set in settings will apply +# to the html that is printed here. +## +$COMPILE{add_form} = __LINE__ . <<'END_OF_SUB'; +sub add_form { + my ($self, $msg) = @_; + print $self->{in}->header; + my $hk = [$self->{table}->ai]; + $msg &&= qq|$msg|; + print $self->_start_html({ title => $msg ? "Add Record Failed" : "Add Record" }); + print $self->_header($msg ? "Add Record Failed" : "Add Record", $msg || "Add a record to the database"); + print $self->_start_form({ do => "add_record", db => $self->{cgi}->{db} }); + print $self->{html}->form({ mode => 'add_form', defaults => 1, hide => $hk, hide_timestamp => 1, search_opts => 0, file_field => 1 }); + print "

        ", $self->_buttons("Add"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + + return 1; +} +END_OF_SUB + +## +# $obj->add_record; +# ----------------------- +# This will add the record to the database and +# return the record ID on success undef on failure. +## +$COMPILE{add_record} = __LINE__ . <<'END_OF_SUB'; +sub add_record { + my $self = shift; + +# Turn arrays into delimited fields + $self->format_insert_cgi; + + if (defined(my $ret = $self->{table}->add($self->{cgi}))) { + $self->add_success($ret); + } + else { + local $^W; + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + + $self->add_form("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->add_success; +# ------------------ +# This will print the success page after adding a +# record. +## +$COMPILE{add_success} = __LINE__ . <<'END_OF_SUB'; +sub add_success { + my ($self, $id) = @_; + print $self->{in}->header; + + my $hsh; + if ($self->{table}->ai) { + $hsh = $self->{table}->get($id, 'HASH'); + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{$_}; } + $hsh = $self->{table}->get($lookup, 'HASH'); + } + + print $self->_start_html({ title => "Record Added" }); + print $self->_header("Record Added", "The following record was successfully added:"); + print "

        "; + print $self->{html}->display({ mode => 'add_success', values => $hsh }); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# DELETE RECORDS # +# ================================================================================ # + +## +# $obj->delete_search_form; +# ------------------------- +# Produces the search form to search to delete records. +# +# $obj->delete_search_form($message); +# ------------------------------------ +# Same thing as above but puts the message at the top in +# red and bold. Great for errors or not search results. +## +$COMPILE{delete_search_form} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html({ title => "Delete Records" }); + print $self->_header("Delete Records", $msg || "Search to delete records."); + print $self->_start_form({ do => "delete_search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'delete_search_form', search_opts => 1 }); + print "

        ", $self->_search_options; + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_search_results; +# ---------------------------- +# Performs the search and returns the result forms +# to delete records. +## +$COMPILE{delete_search_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_search_results { + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->delete_search_form("You must specify at least one search term."); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->delete_search_form("Your search returned no results."); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_start_form({ do => 'delete_records', db => $self->{cgi}->{db} }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + + my @pk; + +# If we have a relation + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ($self->{in}->param('dr') and $self->{in}->param('dr') eq 'rows') { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row({ mode => 'search_results', values => $result }), ""; + print qq~~; + $i++; + } + + print "
        Delete
        \n"; + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display({ mode => 'delete_search_results', values => $result }); + print "
        \n"; + $i++; + } + + } + + + print $speedbar if ($speedbar); + print < 2; # Only print the Check All box if there is more than one thing to check + +

        Check All

        +END_OF_HTML + print "

        ", $self->_buttons("Delete"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->delete_records; +# --------------------- +# Performs the delete and returns the success page. +## +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { + my $self = shift; + +# Make sure we have something to delete. + $self->{cgi}->{delete} or return $self->delete_results(0); + +# If they selected only one record to delete we still need an array ref + ref $self->{cgi}->{delete} eq 'ARRAY' or $self->{cgi}->{delete} = [$self->{cgi}->{delete}]; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{delete}}) { + my $change = {}; + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + next unless (keys %$change); + my $ret = $self->{table}->delete($change); + if (defined $ret and ($ret != 0)) { + $rec_modified++; + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return $self->delete_results($rec_modified); +} +END_OF_SUB + +$COMPILE{delete_results} = __LINE__ . <<'END_OF_SUB'; +sub delete_results { + my ($self, $num_modified) = @_; + print $self->{in}->header; + + print $self->_start_html({ title => "Records Deleted" }); + print $self->_header("Records Deleted", "$num_modified record(s) were deleted."); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY RECORDS # +# ================================================================================ # + +## +# $obj->modify_search_form; +# ------------------------- +# Returns the html form to search to modify a +# record. +# +# $obj->modify_search_form($message); +# ---------------------------------- +# The same thing just puts the message at the top of the +# field. Great for errors. +## +$COMPILE{modify_search_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + print $self->_start_html({ title => "Modify Record" }); + print $self->_header("Modify Record", $msg || "Search to modify a record."); + print $self->_start_form({ do => "modify_search_results", db => $self->{cgi}->{db}, method => 'POST' }); + print $self->{html}->form({ mode => 'modify_search_form', search_opts => 1 }); + print "

        ", $self->_search_options({ modify_mult => 1 }); + print "

        ", $self->_buttons("Search"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_search_results; +# ---------------------------- +# Returns the form that displays the results of a +# search to modify a record. +## +$COMPILE{modify_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_search_results { + my $self = shift; + print $self->{in}->header; + +# If they are modifying multiple records. + if ($self->{cgi}->{modify_multi_form}) { + return $self->modify_multi_search_results(@_); + } + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html({ title => "Search Results" }); + print $self->_start_form({ do => 'modify_form', db => $self->{cgi}->{db} }); + print $self->_header("Search Results", "Your search returned $hits result(s)."); + + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + + if ($self->{in}->param('dr') eq 'rows') { + + print qq!

        !; + print "", $self->{html}->display_row_cols({ mode => 'search_results' }), ""; + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print ""; + print qq~~; + print $self->{html}->display_row({ mode => 'modify_search_results', values => $result }); + print "\n"; + $i++; + } + + print "
        Modify
        \n"; + + + } + + else { + + while (my $result = $sth->fetchrow_hashref) { + foreach my $key (@pk) { + if ($self->{table}->can('_complete_name')) { + my $new = {}; + for (keys %{$result}) { + $new->{$self->{table}->_complete_name($_)} = $result->{$_}; + } + $result = $new; + } + my $val = $result->{$key}; + $self->{html}->escape(\$val); + print qq~~; + } + print qq~

        ~; + print $self->{html}->display({ mode => 'modify_search_results', values => $result }); + print "
        \n"; + $i++; + } + + }; + + + print $speedbar if ($speedbar); + print "

        ", $self->_buttons("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_form($message); +# ------------------ +# Returns the form to modify a single record. +# $message is optional. It will be at the top of the form. +## +$COMPILE{modify_form} = __LINE__ . <<'END_OF_SUB'; +sub modify_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + + my $values; + my $mod = $self->{cgi}->{modify}; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error("Please select a record to modify before continuing."); + } + if ($self->{cgi}->{modify} == 0) { + $values = $self->{cgi}; + } + else { + my $lookup = {}; + for ($self->{table}->pk) { $lookup->{$_} = $self->{cgi}->{"$mod-$_"}; } + $values = $self->{table}->get($lookup, 'HASH'); + } + print $self->_start_html({ title => "Modify Record" }); + print $self->_header("Modify Record", $msg || "Modify a record."); + print $self->_start_form({ do => "modify_record", db => $self->{cgi}->{db} }); + print $self->{html}->form({ mode => 'modify_form', values => $values, view_key => 1, file_field => 1, file_delete => 1 }); + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + print qq( +

        +
        + + ); + print $self->_start_form({ do => "delete_records", db => $self->{cgi}->{db} }, { name => 'admin_delete' }); + print qq(
        ); + for (@pk) { + print qq(); + } + print qq( + + + ); + print qq( +
        +
        + ); + print $self->_end_form; + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_record; +# -------------------- +# Makes the modifications to the record. Returns the +# failure page on error (which is the modify form with a message) +# and the success page on success. +## +$COMPILE{modify_record} = __LINE__ . <<'END_OF_SUB'; +sub modify_record { + my $self = shift; + +# Format arrays for insertion + $self->format_insert_cgi; + + if ($self->{table}->modify($self->{cgi})) { + return $self->modify_success; + } + else { + $self->{cgi}->{modify} = 0; + if ($GT::SQL::errcode eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{$_}; + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if ($rec) { + foreach (keys %$rec) { + $self->{cgi}->{$_} = $rec->{$_}; + } + return $self->modify_form("The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit."); + } + else { + return $self->modify_error("The record you attempted to modify could not be found."); + } + } + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + return $self->modify_form("
        • $error
        "); + } +} +END_OF_SUB + +## +# $obj->modify_success; +# --------------------- +# Returns the success form after someone modifies +# a record. +## +$COMPILE{modify_success} = __LINE__ . <<'END_OF_SUB'; +sub modify_success { + my $self = shift; + print $self->{in}->header; + my $lookup = {}; + my @pk; + if (exists $self->{table}->{tables}) { + for my $t (values %{$self->{table}->{tables}}) { + push @pk, map { $t->name . '.' . $_ } $t->pk; + } + } + else { + @pk = $self->{table}->pk; + } + foreach (@pk) { + $lookup->{$_} = $self->{cgi}->{$_} if (exists $self->{cgi}->{$_}); + } + my $rec = $self->{table}->get($lookup, 'HASH'); + if (! $rec) { + return $self->modify_error("The record you attempted to modify could not be found."); + } + + print $self->_start_html({ title => "Record Modified" }); + print $self->_header("Record Modified", "The following record was successfully updated:"); + print "

        "; + + print $self->{html}->display({ mode => 'modify_success', values => $rec }); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_error; +# --------------------- +# Modify error which doesn't/can't display the record. +## +$COMPILE{modify_error} = __LINE__ . <<'END_OF_SUB'; +sub modify_error { + my $self = shift; + my $msg = shift; + print $self->{in}->header; + + print $self->_start_html({ title => "Modify Error" }); + print $self->_header("Modify Error", $msg); + print "

        ", $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +# ================================================================================ # +# MODIFY MULTIPLE RECORDS # +# ================================================================================ # + +## +# $obj->modify_multi_search_results; +# ------------------------ +# Returns the forms to modify records. +## +$COMPILE{modify_multi_search_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_search_results { + + my $self = shift; + print $self->{in}->header; + +# Make sure the user passed in some values to search on + $self->_check_opts or return $self->modify_search_form("You must specify at least one search term"); + +# Format the cgi for searching + $self->format_search_cgi; + +# Do the search and count the results. + my $sth = $self->{table}->query_sth($self->{cgi}) or return $self->modify_search_form($GT::SQL::error); + my $hits = $self->{table}->hits(); + +# Return if we haven't found anything. + if ($hits == 0) { + return $self->modify_search_form("Your search returned no results."); + } + +# Go straight to the modify form if we only have on result. + if ($hits == 1) { + $self->{cgi}->{modify} = 0; + my $row = $sth->fetchrow_hashref; + foreach (keys %$row) { + $self->{cgi}->{$_} = $row->{$_}; + } + return $self->modify_form(); + } + + print $self->_start_html({ title => "Modify Search Results" }); + print $self->_start_form({ do => 'modify_multi_records', db => $self->{cgi}->{db} }); + print $self->_header("Modify Search Results", "Your search returned $hits result(s)."); + my $speedbar = ''; + if ($hits > ($self->{cgi}->{mh} || 25)) { + my $name = GT::CGI->url(remove_empty => 1); + $speedbar = "

        Pages: "; + $speedbar .= $self->{html}->toolbar($self->{cgi}->{nh} || 1, $self->{cgi}->{mh} || 25, $hits, $name); + $speedbar .= "

        \n"; + print $speedbar; + } + my $i = 1; + while (my $result = $sth->fetchrow_hashref) { + print qq~

        ~; + print $self->{html}->form({ mode => 'modify_multi_search_results', values => $result, multiple => $i, view_key => 1, file_field => 1, file_delete => 1 }); + print "
        \n"; + $i++; + } + print $speedbar if ($speedbar); + print "

        ", $self->_buttons("Modify"); + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +## +# $obj->modify_multi_records; +# --------------------------- +# This performs the modify on the multiple records. This returns +# the success page on error and the modify form on failure. It should +# call the modify form in a way that it can reproduce the records that +# were not successfully modified. See the comments above to see how +# modify_multi_form is called. +## +$COMPILE{modify_multi_records} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_records { + my $self = shift; + if (! exists $self->{cgi}->{modify}) { + return $self->modify_error("Please select a record to modify before continuing."); + } +# If they selected only one record to modify we still need an array ref + ref $self->{cgi}->{modify} eq 'ARRAY' or $self->{cgi}->{modify} = [$self->{cgi}->{modify}]; + +# Format the cgi for inserting + $self->format_insert_cgi; + +# Hash to handle errors if there are any errors. + my $errors = {}; + my $errcode = {}; + +# Need to know the names of the columns for this Table. + my @columns = keys %{$self->{table}->cols}; + +# Need to know the number of records modified + my $rec_modified = 0; + +# For through the record numbers. These are the values of the +# check boxes + foreach my $rec_num (@{$self->{cgi}->{modify}}) { + +# The hash ref, we need, to modify a record. + my $change = {}; + +# For through the column names to build our modification hash + foreach my $column (@columns) { + $change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"}; + } + +# Make the changes and capture any errors. + my $ret = $self->{table}->modify($change); + if (defined $ret) { + $rec_modified++; + } + else { + if ($GT::SQL::error){ + my $error = $GT::SQL::error; + $error =~ s/\n/
        \n

      • /g; + $errors->{$rec_num} = "
      • $error"; + } + $errcode->{$rec_num} = $GT::SQL::errcode if ($GT::SQL::errcode); + } + } + +# Return the results page with the proper arguments depending on if we got an error or not. + return (keys %{$errors}) ? $self->modify_multi_results($rec_modified, $errors, $errcode) : $self->modify_multi_results($rec_modified); +} +END_OF_SUB + +## +# $obj->modify_multi_results($num_modified); +# ------------------------------------------- +# This will return the results page after the user modifies +# the record from the modify_multi_form. $num_modified is the +# number of records that were modified. +# +# $obj->modify_multi_results($num_modified, \%not_modified, \%error_codes); +# ----------------------------------------------------------- +# This is how you handle errors. The first argument is the number +# of records that were modified. The second is a hash ref of primary +# keys to reasons the message was not modified. If there is more than +# one column that makes up the primary key they should be flatened +# to a comma separated list of keys in the proper order. +## +$COMPILE{modify_multi_results} = __LINE__ . <<'END_OF_SUB'; +sub modify_multi_results { + my ($self, $num_modified, $errors, $errcodes) = @_; + my ($ok_out, $error_out) = ('', ''); + $errcodes ||= {}; + +# Lets get our error records if we messed up. + if ($errors) { + my @cond = (); + $error_out = $self->_header("Modify Failed", "The following record(s) were not modified successfully. Please correct the errors and submit again."); + $error_out .= $self->_start_form({ do => 'modify_multi_records', db => $self->{cgi}->{db} }); + + my $cols = $self->{table}->cols; + foreach my $rec (keys %$errors) { + my $values = {}; + if ($errcodes->{$rec} eq 'NORECMOD') { + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= qq~

        The record could not be found in the database~; + $error_out .= qq~
           ~; + $error_out .= $self->{html}->display({ mode => 'modify_multi_results_norec', values => $values }); + $error_out .= qq~
        \n~; + } + elsif ($errcodes->{$rec} eq 'ALREADYCHANGED') { + my $lookup = {}; + for ($self->{table}->pk) { + $lookup->{$_} = $self->{cgi}->{"$rec-$_"}; + } + my $result = $self->{table}->get($lookup, 'HASH'); + foreach (keys %$result) { + $values->{$_} = $result->{$_}; + } + $error_out .= qq~

        The record you are attempting to modify has changed since you last accessed it, please make your changes again and resubmit.~; + $error_out .= qq~
        ~; + $error_out .= $self->{html}->form({ mode => 'modify_multi_result_changed', values => $values, multiple => $rec }); + $error_out .= qq~
        \n~; + } + else { + $error_out .= qq~

        $errors->{$rec}
        ~; + foreach my $col (keys %$cols) { + $values->{$col} = $self->{cgi}->{"$rec-$col"}; + } + $error_out .= $self->{html}->form({ values => $values, multiple => $rec, mode => 'modify_multi_results_err' }); + $error_out .= qq~
        \n~; + } + } + $error_out .= "

        " . $self->_buttons("Modify"); + $error_out .= $self->_end_form; + } + +# If there were successfull modifications. + if ($num_modified) { + $ok_out = $self->_header("Modify Success", "$num_modified record(s) were successfully updated."); + $ok_out .= "

        "; + } + +# Print the HTML + print $self->{in}->header; + print $self->_start_html({ title => "Record Modified" }); + print $ok_out; + print $error_out; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{format_insert_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_insert_cgi { + my $self = shift; + my $cols = $self->{table}->cols; + foreach (keys % $cols) { + if (! exists $self->{cgi}->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX') { + $self->{cgi}->{$_} = ''; + } + } +} +END_OF_SUB + +$COMPILE{format_search_cgi} = __LINE__ . <<'END_OF_SUB'; +sub format_search_cgi { + my $self = shift; + foreach (keys %{$self->{table}->cols}) { + next unless (ref $self->{cgi}->{$_} eq 'ARRAY'); + if (exists $self->{cgi}->{"$_-opt"} and $self->{cgi}->{"$_-opt"} eq 'LIKE') { + $self->{cgi}->{$_} = join("$GT::SQL::Display::HTML::INPUT_SEPARATOR%", sort @{$self->{cgi}->{$_}}); + } + else { + $self->{cgi}->{$_} = join($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$self->{cgi}->{$_}}); + } + } +} +END_OF_SUB + +# ================================================================================ # +# EDIT TABLES # +# ================================================================================ # + +$COMPILE{editor_table_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_table_form { +# ------------------------------------------------------------------- +# $obj->editor_table_form; +# ------------------------ +# Prints the form to edit the table +# definitions. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + +# Update the table if required + $self->{in}->param('update_def') and $msg .= $self->edit_table_def || "Table Definition Update Successful"; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Table Maintenance: $table"); + print $self->_start_form({ do => 'editor_table_form', db => $self->{cgi}->{db}, update_def => 1 }); + my $url = GT::CGI->url({ query_string => 0 }); + + my $show_weight_h = (keys %{$self->{table}->weight}) ? "Index Weight" : ''; + if ($show_weight_h) { + $show_weight_h = qq~Search
        Weight
        ~; + } + else { + $show_weight_h = ''; + } + print qq~ +

        Edit $table Table Definition
        + Below is all the columns in your $table table. By clicking on one of the column names, you can view more details + as well as alter the column definition.

        +
        + + + + + + + + + + + $show_weight_h + + ~; + my %cols = %{$self->{table}->cols}; + foreach my $column ($self->{table}->ordered_columns) { + my %attribs = %{$cols{$column}}; + $attribs{pos} ||= ' '; + $attribs{type} ||= ' '; + $attribs{not_null} ||= ' '; + $attribs{default} = ' ' if not defined $attribs{default} or $attribs{default} eq ''; + $attribs{form_display} ||= ' '; + $attribs{form_type} ||= 'TEXT'; + $attribs{regex} ||= ' '; + + if ($show_weight_h) { + $attribs{weight} ||= ' '; + $show_weight_h = qq~~; + } + ($attribs{not_null} eq '1') ? ($attribs{not_null} = "Yes") : ($attribs{not_null} = "No"); + print qq~ + + + ~; + if ($attribs{protect}) { + print qq~~; + } + else { + print qq~~; + } + print qq~ + + + + + + + $show_weight_h + + ~; + } + print qq~ +
        PositionColumn
        Name
        Column
        Type
        Not
        Null
        DefaultForm
        Display
        Form
        Type
        Form
        Regex
        $attribs{weight}
        $attribs{pos}$column$column$attribs{type}~; + print "($attribs{size})" if ($attribs{size}); + print "(" . join (", " => @{$attribs{values}}) . ")" if ($attribs{values} and (ref $attribs{values})); + print qq~$attribs{not_null}$attribs{default}$attribs{form_display}$attribs{form_type}$attribs{regex}
        +
        + +
        + +
        + + + + + + + +
        Database Information
        Indexing Scheme + +
        +
        + +
        + +
        + + +
        +
        +
        + +
        + ~; + + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{edit_table_def} = __LINE__ . <<'END_OF_SUB'; +sub edit_table_def { +# ------------------------------------------------------------------- + my $self = shift; + my $in = $self->{in}; + +# handle the indexing scheme + my $e = $self->{db}->editor( $in->param('db') ); + $e->change_search_driver( $in->param('search_driver') ) or return $GT::SQL::error; + + return; +} +END_OF_SUB + +$COMPILE{editor_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_columns { +# ------------------------------------------------------------------- +# Form to modify a selected column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + my $column = $self->{cgi}->{modify}; + my %cols = $self->{table}->cols; + my %attribs = %{$cols{$column}}; + my $url = GT::CGI->url({ query_string => 0 }); + exists $cols{$column} or return $self->editor_table_form("Column ($column) does not exist in table" . $self->{table}->name); + +# Print the intro. + print $self->_start_html({ title => "Edit $column Column Definition" }); + print $self->_header("Table Editor", $msg || "Edit $column Column Definition"); + print $self->_start_form({ do => 'editor_modify_columns', db => $self->{cgi}->{db}, modify => $column }); + print qq~ +

        For information on what each column means, click here.

        + ~; + +# Set up defaults for the fields + foreach my $col (qw/column type not_null file_save_in file_save_url file_max_size file_save_scheme default form_display form_type form_size form_names form_values regex weight values size/) { + $attribs{$col} = $self->{cgi}->{$col} if (defined $self->{cgi}->{$col}); + } + $attribs{column} ||= $column; + $attribs{form_type} ||= 'TEXT'; + $attribs{form_size} ||= ($attribs{form_type} eq 'SELECT') ? 0 : ''; + ref $attribs{form_size} and ($attribs{form_size} = join (",", @{$attribs{form_size}})); + ref $attribs{form_names} and ($attribs{form_names} = join ("\n", @{$attribs{form_names}})); + ref $attribs{form_values} and ($attribs{form_values} = join ("\n", @{$attribs{form_values}})); + ref $attribs{values} and ($attribs{values} = join ("\n", @{$attribs{values}})); + +# Display the form. + my $index_list = $self->_index_list($column); + print $self->editor_column_form(\%attribs, $index_list, 'modify'); + + print $self->_buttons("Update Table"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; +} +END_OF_SUB + +$COMPILE{editor_modify_columns} = __LINE__ . <<'END_OF_SUB'; +sub editor_modify_columns { +# -------------------------------------------------------- +# Modifies a column definition. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $column = $self->{cgi}->{modify} || return $self->editor_columns("You must enter a column name."); + foreach my $def (qw/column type not_null default form_display form_type form_size file_save_in file_save_url file_max_size file_save_scheme regex weight size/) { + $attribs{$def} = $self->{cgi}->{$def} if (defined $self->{cgi}->{$def}); + } + $attribs{form_type} ||= 'TEXT'; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + +# Keep any values that where there before + my $old_def = $self->{table}->cols->{$column}; + for my $val (keys %$old_def) { + $attribs{$val} = $old_def->{$val} unless exists $attribs{$val}; + } + +# Error checking + my $errors = $self->editor_column_checks($column, \%attribs, 'modify'); + if ($self->{cgi}->{index} eq 'primary' and ($column ne $self->{table}->{schema}->{pk})) { + $errors .= "

      • This table already has a primary key."; + } + $errors and return $self->editor_columns("
          $errors
        "); + +# Add/Drop indexes. + my $index_type = $self->_index_type($column); + my @post_change; + if ($index_type ne $self->{cgi}->{index}) { + if ($index_type eq 'none') { + # Adding an index - delay this until _after_ the column has been changed + if ($self->{cgi}->{index} eq 'regular') { + push @post_change, [add_index => "${column}_idx" => [$column]]; + } + else { + push @post_change, [add_unique => "${column}_idx" => [$column]]; + } + } + elsif ($self->{cgi}->{index} eq 'none') { + # Dropping an index + if ($index_type eq 'regular') { + my $index = $self->{table}->index; + INDEX: foreach my $index_name (keys %$index) { + foreach my $col_name (@{$index->{$index_name}}) { + next unless ($col_name eq $column); + $editor->drop_index($index_name) or return $self->editor_columns($GT::SQL::error); + last INDEX; + } + } + } + else { + my $unique = $self->{table}->unique; + INDEX: foreach my $unique_name (keys %$unique) { + foreach my $col_name (@{$unique->{$unique_name}}) { + next unless ($col_name eq $column); + $editor->drop_unique($unique_name) or return $self->editor_columns($GT::SQL::error); + last INDEX; + } + } + } + } + } + +# Make the changes + delete $attribs{column}; + $editor->alter_col($column, \%attribs) or return $self->editor_columns($editor->error); + + for (@post_change) { + my ($meth, @args) = @$_; + $editor->$meth(@args); + } + + return $self->editor_table_form("$column has been updated!"); +} +END_OF_SUB + +$COMPILE{editor_column_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_form { +# ------------------------------------------------------------------- +# Displays an Add/Modify column form. +# + my ($self, $attribs, $index_list, $mode) = @_; + + my $output = qq~ +
        + ~; + + if ($mode eq 'add') { + $output .= qq~ + + + ~; + } + + else { + $output .= qq~ + + + + ~; + }; + + my $match = 0; + my @types = qw/INT TINYINT SMALLINT MEDIUMINT BIGINT FLOAT DOUBLE CHAR VARCHAR TEXT DATE DATETIME ENUM/; + for (@types) { + if ($attribs->{type} eq $_) { + $match = 1; + last; + } + } + my $extra = ''; + if (! $match) { + $extra = " + + + + + + + + + + + + + + + + + + ~; + +# Only display Search Weight form if this table has a search weight set. + if (keys %{$self->{table}->weight}) { + $output .= qq~~; + } + + $output .= qq~ +
        Database Information
        Column Name
        Database Information
        WARNING: If you change a field's type, data in that field may be lost. Also, if you alter one of the system fields, it may render your system inoperable.
        Column Name$attribs->{column}
        Column Type +
        Column Index$index_list
        Column Size
        (Only for CHAR types)
        Column Values
        (Only for ENUM types)
        Not Null + + Yes{not_null}); $output .= qq~> + No{not_null}); $output .= qq~> +
        Default
        Form Information
        Form Display
        Form Type +
        Form Size
        Form Names
        (Stored in Database)
        Only for checkbox, multi-select or radio forms.
        Form Values
        (Displayed on Form)
        Only for checkbox, multi-select or radio forms.
        File Save Location
        (Only for FILE types. Stored on disk)
        File Save URL
        (Only for FILE types)
        File Save Method
        (Only for FILE types)
        +
        File Maximum Size
        (Only for FILE types.)
        Form Regex
        Search Weight
        +
        +
        + ~; + return $output; +} +END_OF_SUB + +$COMPILE{editor_column_checks} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_checks { +# ------------------------------------------------------------------- +# Check to make sure a column add/change is valid. +# + my ($self, $column, $attribs) = @_; + my $errors = ''; + +# Remove attributes that don't make sense. + $attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR' or delete $attribs->{size}; + $attribs->{type} eq 'ENUM' or delete $attribs->{values}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_names}; + $attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/ or delete $attribs->{form_values}; + $attribs->{form_type} =~ /^(?:CHECKBOX|RADIO)$/ and delete $attribs->{form_size}; + $attribs->{default} =~ /^\s*$/ and delete $attribs->{default}; + +# Go through and weed out problem cases. + if ($column !~ /^(\w+)$/) { + $errors .= "
      • Column name '$column' is invalid. The column name can only contain letters, numbers and an underscore."; + } + if ($column =~ /^[\d_]/) { + $errors .= "
      • Column name '$column' is invalid. Column names can not start with a number or an underscore."; + } + if (($attribs->{type} eq 'CHAR' or $attribs->{type} eq 'VARCHAR') and ($attribs->{size} > 255 or $attribs->{size} < 1)) { + $errors .= "
      • Size '$attribs->{size}' is invalid. It must be between 1 and 255."; + } + if ($attribs->{type} eq 'ENUM') { + unless (ref $attribs->{values} eq 'ARRAY' and @{$attribs->{values}} >= 1) { + $errors .= "
      • You must specify the ENUM values in the 'Column Value' text area. Enter the value one perl line.
      • \n"; + } + if ($attribs->{default}) { + my $ok; + for my $value (@{$attribs->{values}}) { + $ok = 1, last if $value eq $attribs->{default}; + } + unless ($ok) { + $errors .= "
      • Your default must match one of the listed ENUM values."; + } + } + } + if ($attribs->{type} =~ /INT$/) { + if ($attribs->{default} and $attribs->{default} =~ /\D/) { + $errors .= "
      • The default value for INT columns cannot contain non-integral values.
      • "; + } + } + if ($attribs->{form_type} =~ /^(?:SELECT|MULTIPLE|CHECKBOX|RADIO)$/) { + if (! (@{$attribs->{form_names}} or @{$attribs->{form_values}}) ) { + $errors .= "
      • For radio, checkbox and select forms, you must specify the names and the values in the two textarea boxes one per line. The names are what is stored in the database, and the values is what is displayed in the browser."; + } + else { + if (@{$attribs->{form_names}} ne @{$attribs->{form_values}}) { + $errors .= "
      • Make sure you have the same number of lines for Form Names as you do for Form Values."; + } + } + } + if ($attribs->{form_type} eq 'TEXTAREA') { + if ($attribs->{form_size} =~ /^\s*(\d+)\s*,\s*(\d+)\s*$/) { + $attribs->{form_size} = [$1, $2]; + } + elsif ($attribs->{form_size} =~ /^\s*(\d+)\s*$/) { + $attribs->{form_size} = $1; + } + else { + $errors .= "
      • For TEXTAREA forms, please specify the size of the textarea as COLS,ROWS. For example, to have a 50 column, by 6 rows textarea box, you would enter 50,6 in the Form Size box."; + } + } + if ($attribs->{form_type} eq 'FILE') { + if ( $attribs->{file_save_in}) { + ( -e $attribs->{file_save_in} and -w $attribs->{file_save_in}) or + $errors .= "
      • File Save Location does not exist or is not writeable."; + } + else { + $errors .= "
      • File Save Location must be set."; + } + if ($attribs->{type} ne 'CHAR' and $attribs->{type} ne 'VARCHAR') { + $errors .= "
      • Database column must be of CHAR or VARCHAR."; + } + } + if (($attribs->{not_null} == 0) and ($self->{cgi}->{index} ne 'none')) { + $errors .= "
      • A column must be defined as not null if you want to index it."; + } + if (($self->{cgi}->{index} ne 'none') and ($attribs->{type} eq 'TEXT')) { + $errors .= "
      • You can not have an index on TEXT columns."; + } + if ($attribs->{weight} and $attribs->{weight} !~ /^\d+$/) { + $errors .= "
      • Search weight can only contain digits.
      • "; + } + return $errors; +} +END_OF_SUB + +$COMPILE{editor_add_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field_form { +# ------------------------------------------------------------------- +# Displays a form to add a new column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + +# Set up defaults for the fields + my %attribs = (); + foreach my $def (qw/ + column type not_null default form_display form_type form_size regex weight + size form_names form_values values file_save_in file_save_scheme + file_save_url file_max_size + /) { + $attribs{$def} = defined $self->{cgi}->{$def} ? $self->{cgi}->{$def} : ''; + } + $attribs{form_type} ||= 'TEXT'; + my $url = GT::CGI->url({ query_string => 0 }); + + print $self->_header("Table Editor", $msg || "Add a New Field to $table"); + print $self->_start_form({ do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +

        For information on what each column means, click here.

        + ~; + my $index_list = $self->_index_list(); + print $self->editor_column_form(\%attribs, $index_list, 'add'); + + print $self->_buttons("Add Field to"); + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_add_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_add_field { +# ------------------------------------------------------------------- +# Add a new column to the database. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my %attribs; + my $table = $self->{cgi}->{db}; + my $column = $self->{cgi}->{column} || return $self->editor_add_field_form("You must enter a column name."); + my %cols = $self->{table}->cols; + $attribs{type} = $self->{cgi}->{type} || return $self->editor_add_field_form("You must enter a column type."); + $attribs{size} = $self->{cgi}->{size}; + $attribs{form_display} = $self->{cgi}->{form_display} || $self->{cgi}->{column}; + $attribs{not_null} = $self->{cgi}->{not_null} || 0; + $attribs{default} = $self->{cgi}->{default}; + $attribs{form_type} = $self->{cgi}->{form_type} || 'TEXT'; + $attribs{form_size} = $self->{cgi}->{form_size} || ''; + $attribs{regex} = $self->{cgi}->{regex} || ''; + $attribs{weight} = $self->{cgi}->{weight} || ''; + $attribs{file_save_in} = $self->{cgi}->{file_save_in} || ''; + $attribs{file_save_url} = $self->{cgi}->{file_save_url} || ''; + $attribs{file_max_size} = $self->{cgi}->{file_max_size} || ''; + $attribs{file_save_scheme} = $self->{cgi}->{file_save_scheme} || ''; + $attribs{form_names} = [split /[\r\n]+/, $self->{cgi}->{form_names}]; + $attribs{form_values} = [split /[\r\n]+/, $self->{cgi}->{form_values}]; + $attribs{values} = [split /[\r\n]+/, $self->{cgi}->{values}]; + $attribs{pos} = keys(%cols) + 1; + +# Error checking + my $errors = $self->editor_column_checks($column, \%attribs, 'add'); + if (exists $cols{$column}) { + $errors .= "

      • Column '$column' already exists, please choose another name."; + } + if ($self->{cgi}->{index} eq 'primary') { + $errors .= "
      • You can not add a primary key to an existing table."; + } + $errors and return $self->editor_add_field_form("
          $errors
        "); + +# Add the column. + delete $attribs{column}; + $editor->add_col($column, \%attribs) or return $self->editor_add_field_form("Unable to add column '$column': $GT::SQL::error"); + + my $field_form_message = "The column '$column' was added successfully, however an error occurred while "; + $self->{cgi}->{modify} = $column; +# Add the indexes. + if ($self->{cgi}->{index} eq 'regular') { + $editor->add_index($column . '_idx' => [$column]) or return $self->editor_columns("$field_form_message adding the index: $GT::SQL::error"); + } + elsif ($self->{cgi}->{index} eq 'unique') { + $editor->add_unique($column . '_udx' => [$column]) or return $self->editor_columns("$field_form_message adding the unique index: $GT::SQL::error"); + } + $self->{table}->reload; + + return $self->editor_table_form("The database has been succesfully updated."); +} +END_OF_SUB + +$COMPILE{editor_delete_field_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field_form { +# ------------------------------------------------------------------- +# Displays a form to delete a column. +# + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Delete a Field from $table."); + print $self->_start_form({ do => 'editor_delete_field', db => $self->{cgi}->{db} }); + + print qq~ +
        +
        +

        WARNING: If you remove a field, all data in that field will be lost. Also, if you remove + one of the system fields, certain functions may not work any more!

        ~; + my @cols = grep !exists $self->{table}->{schema}->{cols}->{$_}->{protect}, $self->{table}->ordered_columns; + if (@cols) { + print qq~ + Delete the following field: + +

        + ~; + } + else { + print qq<

        No columns can be deleted.

        >; + } + print qq~ +
        +
        +
        + ~; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_delete_field} = __LINE__ . <<'END_OF_SUB'; +sub editor_delete_field { +# ------------------------------------------------------------------- +# Remove a field from the table. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my $table = $self->{cgi}->{db}; + my $field = $self->{cgi}->{'delete-field'} || return $self->editor_delete_field_form("Please select a field to delete!"); + ($field eq 'ID') and return $self->editor_delete_field_form("You can't remove the ID field."); + +# Drop the column from the database. + $editor->drop_col($field) or return $self->editor_delete_field_form($GT::SQL::error); + + return $self->editor_delete_field_form("The database has been successfully updated."); +} +END_OF_SUB + +$COMPILE{editor_update_def} = __LINE__ . <<'END_OF_SUB'; +sub editor_update_def { +# ------------------------------------------------------------------- +# Re-sync the def file with what's in the database. +# + my $self = shift; + +# We need a creator for this. + my $c = $self->{db}->creator($self->{table}->name); + $c->load_table or return $self->editor_table_form("Could not update def files reason $GT::SQL::error"); + +# Re Load our table object. + $self->{table}->reload; + + return $self->editor_table_form("The .def file has been re-synced."); +} +END_OF_SUB + +$COMPILE{editor_column_help} = __LINE__ . <<'END_OF_SUB'; +sub editor_column_help { +# -------------------------------------------------------- +# Displays a help page for the editor. +# + my ($self, $msg) = @_; + my $table = $self->{cgi}->{db}; + print $self->{in}->header; + print $self->_start_html; + print $self->_header("Table Editor", $msg || "Add/Edit Columns Help."); + print $self->_start_form({ do => 'editor_add_field', db => $self->{cgi}->{db} }); + print qq~ +
        + +

        From here you can add a new column to your table $table. When creating your column, you should set the following options: +

          +
        • Column Name: This is the name of your column. It must be a valid SQL name, which is just letters, numbers and the underscore character. Also, + try to avoid reserved words like FROM, SELECT, WHERE, JOIN, etc. +
        • Column Type: This is the type of column you want to create. Your choices are: +
            +
          • INT: This stores integer numbers, i.e. 1, 2, 3. Whole numbers without decimal points between -2147483648 and 2147483647. +
          • TINYINT: This stores integers between -128 and 127. +
          • SMALLINT: This stores integers between -32768 and 32767. +
          • MEDIUMINT: This stores integers between -8388608 and 8388607. +
          • BIGINT: This stores integers between -9223372036854775808 and 9223372036854775807. +
          • FLOAT: This stores 32-bit floating point numbers. +
          • DOUBLE: This stores 64-bit floating point numbers. +
          • CHAR: This stores any string up to a maximum size of 255. If you set a CHAR, you must set the + maximum size in Column Size. +
          • VARCHAR: This is the same as a CHAR column type except in the way it is stored and retrieved + from the database. +
          • TEXT: This stores a (virtually) unlimited amount of text. Use this for storing very large + amounts of texts. +
          • DATE: This stores a date defaulting to yyyy-mm-dd format. +
          • ENUM: This stores an enumerated list. This is useful when you want a field that can be + one of several values. For example, you could create a Status column that can contain + the values: 'Not Registered', 'Registered', 'Moderator', 'SuperUser'. The entries in this + column must be one of the listed values. You specify what values you want using one line + per entry in the Column Values field. +
          +
        • Column Index: This determins what sort of index the SQL server should use to speed up queries. If you use + an index, you must set Not Null to Yes. +
        • Column Size: This is only useful for CHAR types. It stores the maximum size a field can be and should range + anywhere from 1 to 255. +
        • Column Values: This is only useful for ENUM types. It stores the list of possible values, one per line. +
        • Not Null: If you set this to Yes, then a value must be entered for this column. If you set this to No, then + when you add a record, this column can be left blank. +
        • Default: This is the default value that will be displayed when adding a record. +
        • Form Type: This is the type of form to use when adding or modifying a record. Your choices are: +
            +
          • Hidden: This column will be hidden on the add and modify forms. +
          • Select: A select list will be generated. For select lists, Form Size determines the size + of the select list (set to 0 for a single select list, higher for multiple select lists). You should + enter the values of the select list (what will be displayed to the user) in the Form Values textarea, and + the data of the select list (what will be stored in the database) in the Form Names textarea. +
          • Checkbox: This generates a set of checkboxes. You need to enter into Form Values a list of all + the checkbox values (what will be displayed to the user), and in Form Names, a list of what will be stored + in the database. The data is stored in the database joined on a new line. +
          • Radio: This generates a radio option list. You must enter into Form Names the value that will be stored in the database, + and in Form Values, the value that will be displayed. +
          • Text: This generates a simple text box. You can set the size of text box using Form Size. +
          • Textarea: This generates a textarea field. You can set the rows and columns to use in the Form Size by entering rows,cols + (for example: 30,4). +
          • Password: This generates a password box. You can set the size of password box using Form Size. +
          • File: This creates a standard file field. You must set the File Save Location and set the database type to CHAR. +
          +
        • Form Size: This is only useful for select, text or textarea form types. For selects, set this to 0 to be a single + select field, set it to a postive number to be a multi select field. For Text fields, set this to the size of the text box, for + textarea types, set this to rows,cols to specify the size. +
        • Form Names: This is only useful for Select, Checkbox or Radio types. This is what will be stored in the database. You + should enter one value per line. +
        • Form Values: This is only useful for Select, Checkbox or Radio types. This is what will be displayed to the user. You should + enter one value per line. + +
        • File Save Location: Specifies in which directory where the the files are saved. Once you have set this, please try not to + change the save path. If you must, do not move the existing files unless you are prepared to prepared to update your + "@{[$self->{table}->name()]}_Files" table to reflect the move. + +
        • File Save URL: If this directory is accessibly by URL, specjfiy the base url here. This will allow retrieval of the full URL + path to the file should you want to display the file for viewing or download. + +
        • File Save Method: Once this has been set, please do not change unless there are no files being handled by the system. + This option sets how the files are to be stored in the directory. If you expect many files to be uploaded, the system will + use a collection of different directories to store the files. This allows faster lookups for by the OS and experienced + users will be able to "symlink" some of the directories to other harddrives to distribute the load. + +
        • File Maximum Size: Caps the maximum number of bytes of files users can upload. + +
        • Form Regex: This is a perl regular expression that data must match before being inserted or updated. +
        • Search Weight: If this is set to a positive value, this field will be included in the search index. Note: you must + rebuild the search index after changing/adding a search weight. +
        +

        +
        +
        + ~; + print "

        "; + print $self->_prop_navbar; + print $self->_end_form; + print $self->_footer; + print $self->_end_html; + return; +} +END_OF_SUB + +## +# $self->editor_import_data_form; +# ------------------------------- +# Prints the page to import data. +## +$COMPILE{editor_import_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + $msg &&= qq|$msg|; + my $table = $self->{record}; + + + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Import Data to $table."); + print $self->_start_form({ do => 'editor_import_data', db => $self->{cgi}->{db} }, { name => 'ImportForm'}); + + +print qq~ + +~; + + print qq~ +
        +

        You can either import from a file or you can cut and paste the contents into a textarea box. If you + have a large number of records, you should really import from a file. If you use quick mode, the file must contain the same + number of fields as the current table, and in the same order. If you don't use quick mode, the first line of either the file + or the text box must be a list of column names!
        +   +

        + +
        +
        + Fields to Import
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        +
        + + ~; + + print qq| +
        +
        +
        +

        + Import data from file: or from textarea box:
        +
        + Use as delimiter. + Delete old data first +
          +

        + ~; + print $self->_buttons("Import Data into"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_import_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_import_data { +# -------------------------------------------------------- +# Import data from textarea box or file. +# + my $self = shift; + my ($delim, $file, $text, $res, @header); + + $delim = $self->{cgi}->{'import-delim'} || return $self->editor_import_data_form("No import delimiter specified!"); + $file = $self->{cgi}->{'import-file'}; + $text = $self->{cgi}->{'import-text'}; + +# Make sure they have picked the fields to import + $self->{cgi}->{'ImportRight'} or return $self->editor_import_data_form("No fields selected to import"); + @header = reverse ((ref ($self->{cgi}->{'ImportRight'}) eq 'ARRAY') ? @{$self->{cgi}->{'ImportRight'}} : $self->{cgi}->{'ImportRight'}); + + my $todo = 0; + for (@header) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_import_data_form("No fields selected to import") } + +# Make sure there is some data to import + $file or $text or return $self->editor_import_data_form("You must enter at least a filename or data in the textarea box."); + $file and $text and return $self->editor_import_data_form("Please only enter either a filename or data in the textarea box, not both."); + $delim = "\t" if $delim eq '\t'; + +# Store the lines to import in @lines and the header in $header. + my ($good_cnt, $err_cnt, $line, $line_num, @lines, @data, $error, %record, $i); + if ($file) { + open (FILE, "<$file") or return $self->editor_import_data_form("Unable to open file '$file': $!"); + local $/; + @lines = split /[\r\n]+/, ; + close FILE; + } + else { + @lines = split /[\r\n]+/, $text; + } + +# Remove old data if requested. + my $table = $self->{cgi}->{db}; + if ($self->{cgi}->{'import-delete'}) { + $self->{table}->delete_all; + } + +# Do the import. + $good_cnt = $err_cnt = 0; + LINE: for my $line_num (0 .. $#lines) { + ($err_cnt > 10) and last LINE; + $line = $lines[$line_num]; + @data = split /\Q$delim\E/, $line, -1; + if ($#data != $#header) { + $error .= "

      • " . ($line_num+2) . ": Row count: " . ($#data+1) . + " does not match header count: (@data) (@header)" . ($#header+1) . "\n"; + $err_cnt++; + next LINE; + } + $i = 0; + %record = (); + for (@data) { + $data[$i] =~ s/``/$delim/g; + $data[$i] =~ s/~~/\n/g; + $record{$header[$i]} = $data[$i]; + $i++; + } + unless ($line_num){ # check the first line and ignore it if this is a header line + my @check_diff = grep $record{$_} ne $_ => @data; + (@check_diff) or next LINE; + } + if (!$self->{table}->add(\%record, 1)) { + $error .= "
      • " . ($line_num+2) . ": Failed validation. Error:
          $GT::SQL::error
        \n"; + $err_cnt++; + next LINE; + } + $good_cnt++; + } + +# Return the results. + if ($error) { + return $self->editor_import_data_form(($err_cnt >= 10) ? + "Aborting, too many errors!

        Rows imported: $good_cnt
        Errors with the following rows: +
          $error

        " : + "Rows imported: $good_cnt
        Errors with the following rows:
          $error

        "); + } + return $self->editor_import_data_form("Rows imported: $good_cnt."); +} +END_OF_SUB + +## +# $self->editor_export_data_form; +# ------------------------------- +# Prints the page to export data. +## +$COMPILE{editor_export_data_form} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data_form { + my ($self, $msg) = @_; + print $self->{in}->header; + + $msg &&= qq|$msg|; + my $table = $self->{record}; + print $self->_start_html({ title => "Table Editor: $table" }); + print $self->_header("Table Editor", $msg || "Export Data from $table."); + +print qq~ + +~; + print $self->_start_form({ do => 'editor_export_data', db => $self->{cgi}->{db} }, {name => 'ExportForm'}); + + print qq~ +
        +

        You can either export your data from $table table to the screen or to a file. + If you have a large amount of + data it is recommended to export the contents to a file. Quick mode should be + used when exporting to a file as it + uses the SQL server to do the exporting and is considerably faster.
          +

        + + + +
        +
        + Fields to Export
        + ~; + + my @cols = $self->{table}->ordered_columns; + print qq| +
        +
        +
        + ~; + + print qq| +
        +
          +
        + Export data to: + filename:
        + Use as delimiter. +
        +
        + ~; + print $self->_buttons("Export Data from"); + print "

        "; + print $self->_end_form; + print $self->_prop_navbar; + print "

        "; + print $self->_footer; + print $self->_end_html; + +} +END_OF_SUB + +$COMPILE{editor_export_data} = __LINE__ . <<'END_OF_SUB'; +sub editor_export_data { +# -------------------------------------------------------- +# Export data to text file/screen. +# + my $self = shift; + ref $self->{cgi}->{db} + and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation."); + my $editor = $self->{db}->editor($self->{cgi}->{db}); + + my ($delim, $quick, $res); + + $self->{cgi}->{'ExportRight'} or return $self->editor_export_data_form("No fields selected to export."); + my @order = reverse(ref $self->{cgi}->{'ExportRight'} eq 'ARRAY' ? @{$self->{cgi}->{'ExportRight'}} : $self->{cgi}->{'ExportRight'}); + + my $todo = 0; + for (@order) { + unless (/^$/) { + $todo = 1; + last; + } + } + unless ($todo) { return $self->editor_export_data_form("No fields selected to Export.") } + + $delim = $self->{cgi}->{'export-delim'}; + ($delim eq '\t') and ($delim = "\t"); + + if ($self->{cgi}->{'export-mode'} eq 'file') { + $self->{cgi}->{'export-file'} or return $self->editor_export_data_form("Please enter a file name!"); + $editor->export_data( + { + file => $self->{cgi}->{'export-file'}, + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form($GT::SQL::error); + return $self->editor_export_data_form("Data has been exported to: $self->{cgi}->{'export-file'}"); + } + else { + print $self->{in}->header; + $editor->export_data( + { + delim => $delim, + header => 1, + order => \@order + } + ) or return $self->editor_export_data_form($GT::SQL::error); + return; + } +} +END_OF_SUB + +# ================================================================================ # +# PRIVATE/INTERNAL METHODS # +# ================================================================================ # + +## +# $self->_check_opts; +# ------------------- +# This checks to make sure the user specified at least one +# column to search on. +## +$COMPILE{_check_opts} = __LINE__ . <<'END_OF_SUB'; +sub _check_opts { + my $self = shift; + my $sel = 0; + +# Relation does not play fare :( + my $cols = $self->{table}->cols; + for (keys %{$self->{cgi}}) { $sel = 1 if (($self->{cgi}->{$_} =~ /\S/) and exists $cols->{$_}) } + if ((exists $self->{cgi}->{query} and $self->{cgi}->{query} =~ /\S/) or + (exists $self->{cgi}->{keyword} and $self->{cgi}->{keyword} =~ /\S/)) { + $sel = 1; + } + $sel or return; + return 1; +} +END_OF_SUB + +## +# $self->_header; +# --------------- +# Returns the header to be used with the forms, error pages, etc... +## +$COMPILE{_header} = __LINE__ . <<'END_OF_SUB'; +sub _header { + my ($self, $head, $msg) = @_; + if ($self->{header}) { + if (ref $self->{header} eq 'CODE') { + return $self->{header}->($self, $head, $msg); + } + else { + return $self->{header}; + } + } + else { + my $out = qq~ + + + + +
        + + + + + + + +
        + $self->{record}: $head +
        +

        $self->{record}: $head

        +

        $msg

        +
        +
        + ~; + } +} +END_OF_SUB + +## +# $self->_footer; +# --------------- +# Returns the footer to set for each form. +## +$COMPILE{_footer} = __LINE__ . <<'END_OF_SUB'; +sub _footer { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + if ($self->{footer}) { + if (ref $self->{footer} eq 'CODE') { + my $ret = $self->{footer}->($self); + return $ret if (defined $ret); + } + else { + return $self->{footer}; + } + } + my $url = GT::CGI->url({ query_string => 0 }) . "?"; + my @vals = GT::CGI->param('db'); + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + my $ret = qq~ +
        +
        +
        $self->{record}: + Add | + Modify | + Delete | + Search + ~; + if (!exists $self->{table}->{tables}) { + $ret .= qq~ | + Properties + ~; + } + $ret .= qq~ +
        +
        + ~; + return $ret; +} +END_OF_SUB + +$COMPILE{_prop_navbar} = __LINE__ . <<'END_OF_SUB'; +sub _prop_navbar { + my $self = shift; + +# Get the variables that need to be preserved and generate urls for them. + my $preserve_hash = $self->preserve(); + my $preserve = ''; + foreach my $p (keys %$preserve_hash) { + $preserve .= qq|&$p=$preserve_hash->{$p}|; + } + + my @vals = GT::CGI->param('db'); + my $url = GT::CGI->url({ query_string => 0 }) . "?"; + foreach my $val (@vals) { + $url .= "db=" . GT::CGI->escape($val) . "&"; + } + chop $url; + return qq~ + +
        + + +
        Properties: + Add Column | + Delete Column | + Import Data | + Export Data | + Resync Database +
        +
        + ~; +} +END_OF_SUB + +## +# $self->_search_options; +# --------------- +# Returns the search options. +## +$COMPILE{_search_options} = __LINE__ . <<'END_OF_SUB'; +sub _search_options { + my $self = shift; + my $opts = shift; + if ($self->{search_options}) { + if (ref $self->{search_options} eq 'CODE') { + return $self->{search_options}->($self, $opts); + } + else { + return $self->{search_options}; + } + } + +# First, figure out the sort by columns. + my $c = $self->{table}->cols; + my ($hash, $order) = ({}, []); + foreach my $col (sort { + defined $c->{$a}->{pos} or warn "No pos for $a\n"; + defined $c->{$b}->{pos} or warn "No pos for $b\n"; + + $c->{$a}->{'pos'} <=> $c->{$b}->{'pos'} + } keys %$c) { + $hash->{$col} = $c->{$col}->{form_display} || $col; + push @$order, $col; + } + my $sb = $self->{html}->select( + { + name => "sb", + values => $hash, + sort_order => $order, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $so = $self->{html}->select( + { + name => "so", + values => { + 'ASC' => 'Ascending', + 'DESC' => 'Descending' + }, + default => $self->{cgi}->{sb}, + blank => 1 + } + ); + + my $dr = $self->{html}->select( + { + name => "dr", + values => { + '' => 'As Elements', + 'rows' => 'As Rows' + }, + default => $self->{cgi}->{dr}, + blank => 1 + } + ); + +# Then set the rest of the form options. + my $ma = exists $self->{cgi}->{ma} ? 'CHECKED' : ''; + my $mh = exists $self->{cgi}->{mh} ? $self->{cgi}->{mh} : 25; + my $kw = exists $self->{cgi}->{keyword} ? $self->{cgi}->{keyword} : ''; + my $idx = exists $self->{cgi}->{indexed} ? $self->{cgi}->{indexed} : ''; + + my $out = qq~ + +
        + + + + + + + + + + + + + + + + + + + + + ~; + + if ( ( () = $self->{in}->param('db') ) == 1 ) { + $out .= qq~ + + + + + ~; + } + + if (exists $opts->{modify_mult} and $opts->{modify_mult}) { + $out .= qq~ + + + + + ~; + } + $out .= qq~ +
        Maximum Hits:Match Any:
        Keyword Search:
        Indexed Search:
        Sort By:$sbUsing:$so
        Display Records:$dr
        Modify Multiple:
        +
        + ~; + return $out; +} +END_OF_SUB + +## +# $self->_start_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_form} = __LINE__ . <<'END_OF_SUB'; +sub _start_form { + my $self = shift; + my $opts = shift || {}; + my $meth = exists $opts->{method} ? $opts->{method} : 'POST'; + my $attrib = shift || {}; + +# If a code ref was specified execute it and return the output to be printed + if ($self->{start_form}) { + if (ref $self->{start_form} eq 'CODE') { + return $self->{start_form}->($self, $opts, $meth); + } + else { + return $self->{start_form}; + } + } + +# Get the variables that need to be preserved and generate hidden tags for them. + my $preserve = $self->preserve(); + my $hidden_tags = ''; + foreach my $p (keys %$preserve) { + $hidden_tags .= qq||; + } + + my $out = ''; my @vals; + my $url = GT::CGI->url({ query_string => 0 }); + my $att = ' '; + $attrib->{name} ||= 'admin'; + foreach (keys %{$attrib}) { $att .= qq|$_="$attrib->{$_}" | } + foreach my $key (keys %$opts) { + next if ($key eq 'method'); + my $val = $opts->{$key}; + (ref $val eq 'ARRAY') ? (@vals = @$val) : (@vals = ($val)); + foreach my $val2 (@vals) { + $self->{html}->escape(\$val2); + $out .= qq~~; + } + } + my $mimeenc = $self->{table}->_file_cols() ? 'enctype="multipart/form-data"' : ''; + return qq~

        $hidden_tags$out\n~; +} +END_OF_SUB + +## +# $self->_end_form; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_form} = __LINE__ . <<'END_OF_SUB'; +sub _end_form { + my $self = shift; + if (defined $self->{end_form} and $self->{end_form}) { + if (ref $self->{end_form} eq 'CODE') { + return $self->{end_form}->($self); + } + else { + return $self->{end_form}; + } + } + return "
        \n"; +} +END_OF_SUB + +## +# $self->_start_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_start_html} = __LINE__ . <<'END_OF_SUB'; +sub _start_html { + my $self = shift; + my $opts = shift || {}; + if ($self->{start_html}) { + if (ref $self->{start_html} eq 'CODE') { + return $self->{start_html}->($self, $opts); + } + else { + return $self->{start_html}; + } + } + my $title = exists $opts->{title} ? $opts->{title} : ''; + my $body = exists $opts->{body} ? $opts->{body} : $BODY; + return qq~\n$title: $self->{record}\n~; +} +END_OF_SUB + +## +# $self->_end_html; +# ------------------------- +# Display the opening form tag. +## +$COMPILE{_end_html} = __LINE__ . <<'END_OF_SUB'; +sub _end_html { + my $self = shift; + if ($self->{end_html}) { + if (ref ($self->{end_html}) eq 'CODE') { + return $self->{end_html}->($self); + } + else { + return $self->{end_html}; + } + } + return "\n\n"; +} +END_OF_SUB + +## +# $self->_buttons; +# ------------------------- +# Display closing table with form buttons. +## +$COMPILE{_buttons} = __LINE__ . <<'END_OF_SUB'; +sub _buttons { + my $self = shift; + my $name = shift; + return qq~ +
        +
        +
        + ~; +} +END_OF_SUB + +$COMPILE{_index_list} = __LINE__ . <<'END_OF_SUB'; +sub _index_list { + my ($self, $column) = @_; + my $indexed = $self->{cgi}->{index} || 'none'; + if ($column and ! $self->{cgi}->{index}) { + $indexed = + $self->{table}->_is_indexed($column) ? 'regular' : + $self->{table}->_is_unique($column) ? 'unique' : + $self->{table}->_is_pk($column) ? 'primary' : + 'none'; + } + if ($column and $indexed eq 'primary') { + return "Primary Key"; + } + my $output = '"; + return $output; +} +END_OF_SUB + +$COMPILE{_index_type} = __LINE__ . <<'END_OF_SUB'; +sub _index_type { + my ($self, $column) = @_; + my $indexed = 'none'; + if ($column) { + $self->{table}->_is_indexed($column) and ($indexed = 'regular'); + $self->{table}->_is_unique($column) and ($indexed = 'unique'); + $self->{table}->_is_pk($column) and ($indexed = 'primary'); + } + return $indexed; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Admin - instant admin for any sql table. + +=head1 SYNOPSIS + + my $cgi = new GT::CGI; + my $db = new GT::SQL '/path/to/def'; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process(db => $db, cgi => $cgi); + } + +=head1 DESCRIPTION + +GT::SQL::Admin provides an easy way to build a table/relation +management application. It provides all the HTML and code to +easily: + + 1. Add records + 2. Delete records + 3. Modify records + 4. Search records + 5. Add columns + 6. Drop columns + 7. Alter table properties + 8. Import data + 9. Export data + +all in about 6 lines of code. + +=head2 Usage + +To use GT::SQL::Admin you need to pass in an existing +L object, and a L object. + +In it's simplest usage, you can simply call: + + my $admin = new GT::SQL::Admin; + $admin->process(db => $db, cgi => $cgi); + +and the admin module will figure out what was requested and display +the appropriate screen. There is a $admin->for_me method that will +look to see if the cgi object contains something for the admin +to do, returning 1 if yes, 0 otherwise. You would then do: + + my $cgi = new GT::CGI; + my $admin = new GT::SQL::Admin; + if ($admin->for_me($cgi)) { + $admin->process(db => $db, cgi => $cgi); + } + +You can also call any of the methods individually. You can create an +add form like: + + $admin->add_form; + +and it will be printed to STDOUT. + +To change the look of a page, you can pass in strings or code refs +to display any of the following items: + + start_html + header + start_form + end_form + footer + end_html + +and the admin will use your html/code when displaying. You can also pass +in to process: + + record => 'MyObject' + +and the admin will use that string when displaying titles like 'Add MyObject'. +If you don't specify, it will default to the name of the table. + +=head2 Subclassing the admin + +You can enhance the functionality of an admin quite easily. By default +GT::SQL::Admin expects to find a GT::SQL object, a GT::CGI object, and uses +internally a GT::SQL::Display::HTML object for any form/record html +generation. + +Alternatively, you can subclass one or more of the above and use your +own libraries. For instance, if you wanted to expand the form generation, +you could subclass the GT::SQL::Display::HTML object and override the display() +and form() method with your own. + +The admin will pass in a 'mode' to both display and form that will tell +you what it is using the form for. This can be one of: + + search_form + search_results + add_form + add_success + delete_search_form + delete_search_results + download_file + modify_search_form + modify_search_results + modify_form + modify_success + modify_multi_search_results + modify_multi_results_norec + modify_multi_result_changed + modify_multi_results_err + + +There are also several options that can be passed in. See the +L module for more information. + +Also be sure to read about subclassing in L. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Admin.pm,v 1.161 2009/05/11 22:57:15 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm new file mode 100644 index 0000000..446a6eb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm @@ -0,0 +1,607 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# CVS Info : 087,071,086,086,085 +# $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt 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.72 $ =~ /(\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} and $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} and $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} and $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 "")) { + push @ins, [$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 %{$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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Condition.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Condition.pm new file mode 100644 index 0000000..cea3d79 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Condition.pm @@ -0,0 +1,404 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 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.45 $ =~ /(\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 $_[-1] and (uc $_[-1] eq 'AND' or uc $_[-1] eq 'OR' or $_[-1] 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 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 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 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 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.45 2006/02/16 20:26:14 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Creator.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Creator.pm new file mode 100644 index 0000000..d4634a6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Creator.pm @@ -0,0 +1,1216 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Creator; +# =============================================================== +use GT::SQL; +use GT::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $error $ERROR_MESSAGE/; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.74 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::Base/; +$DEBUG = 0; + +sub new { +# ------------------------------------------------------------------- +# Setup a new creator object. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = {}; + if (@_ == 0) { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). No arguments") } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (not @_ % 2) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). Wrong arguments") } + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH); No table passed in to creator."); + + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + + $self->debug("OBJECT CREATED") if $self->{_debug} > 2; + return $self; +} + +## +# $obj->create; +# ------------------- +# Checks to see that the table is not there. +# Returns undef if it is. If the table is not +# there creates the table. +# +# $obj->create("force"); +# ----------------------------- +# This will check to see if the table is there. +# If it is create_table will drop the table +# then create the current one. +## +sub create { + my $self = shift; + my $force = shift || 'check'; + my $opts = shift || {}; + + $self->{table}->connect() or return; +# Error checking + $self->{table}->check_schema or return; + keys %{$self->{table}->cols} or return $self->fatal('NOTABLEDEFS'); + if ($self->_uses_weights) { $self->_get_indexer()->pre_create_table() or return } + + my $table_name = $self->{table}->name(); + +# Force the creation if force is specified + if ($force eq 'force') { + $self->debug("Forcing the table creation") if $self->{_debug} > 1; + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + $self->debug("Table $table_name exists. Dropping table") if ($self->{_debug} > 1); + $self->drop_table; + } + else { + $self->debug("Not dropping table $table_name because it does not exist") if $self->{_debug} > 1; + } + } + elsif ($force eq 'check' or $force eq 'upgrade' ) { + my $ret; + { + local ($SIG{__DIE__}, $@); + eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") }; + $GT::SQL::error = ''; + } + if (defined $ret) { + if ( $force eq 'upgrade' ) { + return $self->_consolidate( $opts ); + } + else { + return $self->warn(TBLEXISTS => $table_name); + } + } + } + + $self->{table}->{driver}->create_table($force) or return; + + +# Set up some defaults + $self->set_defaults; + $self->{table}->save_state or return; + +# now that the table has been made, if the user has requested weighted-indexing of tables, handle that + if ($self->_uses_weights) { $self->_get_indexer()->post_create_table() or return } + +# then handle anything related to file databases + $self->_file_create_tables(); + return 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if $self->{_debug} > 2; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +$COMPILE{_file_create_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_create_tables { +# creates file upload tables if required + my $self = shift; + + if ( $self->{table}->_file_cols() ) { + +# ... create the table because we have file columns + require GT::SQL::File; + my $ftable = GT::SQL::File->new( + table => $self->{table}, + connect => $self->{connect} + ); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + + }; + $self->{table}->_file_cols(1); +} +END_OF_SUB + +sub set_defaults { + my $self = shift; + my %cols = ref $_[0] ? %{shift()} : $self->{table}->cols(); + my %file_defs = (form_type => 'FILE', form_size => '20', file_save_in => '.', file_save_scheme => 'HASHED'); + + for my $col (keys %cols) { + + my $attrib = $cols{$col}; + if ($attrib->{type} =~ /char/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + + if ($attrib->{form_type} and $attrib->{form_type} =~ /file/i) { + my $col_info = $self->{table}->{schema}->{cols}->{$col}; + for (qw(form_type form_size file_save_in file_save_scheme)) { + $col_info->{$_} ||= $file_defs{$_} unless $col_info->{$_}; + } + + $col_info->{file_log_path} ||= $col_info->{file_save_in}; + } + } + elsif ($attrib->{type} =~ /text|blob/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXTAREA'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 30; + } + elsif ($attrib->{type} =~ /int|double|float/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 10; + } + elsif ($attrib->{type} =~ /enum/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'SELECT'; + } + elsif ($attrib->{type} =~ /date|timestamp/i) { + $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'DATE'; + $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20; + } + } + +} + + +## +# $obj->load_table; +# ----------------- +# Creates a schema based on an existing sql +# table and saves it. +## +$COMPILE{load_table} = __LINE__ . <<'END_OF_SUB'; +sub load_table { + my $self = shift; + $self->{table}->connect() or return; + $self->_load_table(@_) or return; + $self->{table}->save_state() or return; +} +END_OF_SUB + +$COMPILE{_load_table} = __LINE__ . <<'END_OF_SUB'; +sub _load_table { + my $self = shift; + $self->debug("DESCRIBE $self->{table}->{name}") if $self->{_debug}; + my $sth = $self->{table}->{driver}->prepare("DESCRIBE $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pos, %index, %unique, %cols, @pk, %other) = (1); + + # Default to the current ai value, if any, because some databases don't + # associate an increment to a value (such a postgres, where sequences are + # completely separate from tables and columns) + my $ai = $self->{table}->ai; + + my $table_name = $self->{table}->name; + my %col_case_map = map { lc $_ => $_ } keys %{$self->{table}->cols}; + my %index_case_map = map { lc $_ => $_ } keys %{$self->{table}->index}; + my %unique_case_map = map { lc $_ => $_ } keys %{$self->{table}->unique}; + +# Get the column defintions. + while (my $col = $sth->fetchrow_hashref) { + my $name = $col_case_map{lc $col->{Field}} || $col->{Field}; + my $type = $col->{Type}; + my $not_null = $col->{Null} ? 0 : 1; + my $default = ($col->{Default} and $col->{Default} ne 'NULL') ? $col->{Default} : undef; + $ai = $name if $col->{Extra} and $col->{Extra} =~ /AUTO/i; + $_ = $type; + + if (/^((?:var)?char)\((\d+)/i) { + %other = (type => uc $1, size => $2); + $other{binary} = 1 if /binary/i; + } + elsif (/^(var)?binary\((\d+)/i) { + %other = (type => "\U${1}char", size => $2); + $other{binary} = 1; + } + elsif (/^((?:tiny|small|medium|big)?int)/i) { + %other = (type => uc $1); + $other{zerofill} = 1 if /zerofill/i; + $other{unsigned} = 1 if /unsigned/i; + } + # decimal(10,5) + elsif (/^(?:decimal)\((\d+),\s*(\d+)\)/i) { + %other = (type => 'DECIMAL', precision => $1, scale => $2); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:double|float8)/i) { + %other = (type => 'DOUBLE'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(?:float|real)/i) { + %other = (type => 'REAL'); + $other{zerofill} = 1 if /zerofill/i; + } + elsif (/^(datetime|date|timestamp|time|year|(?:tiny|medium|long)?(?:text|blob))/i) { + %other = (type => uc $1); + } + elsif (/^enum\('([^\)]+)'\)/i) { + %other = ( + type => 'ENUM', + values => [split /'\s*,\s*'/, $1] + ); + } + else { + return $self->fatal(BADTYPE => $type); + } + my %col = ( + pos => $pos, + %other + ); + $col{default} = $default if defined $default; + $col{not_null} = 1 if $not_null; + $cols{$name} = \%col; + $pos++; + } + + # Retrieve index information + $sth = $self->{table}->{driver}->prepare("SHOW INDEX FROM $self->{table}->{name}") or return; + $sth->execute() or return; + my ($pk_index_name, @pk_index_cols); + while (my $index = $sth->fetchrow_hashref) { + my $name = lc $self->{table}->{driver}->extract_index_name($self->{table}->{name}, $index->{index_name}); + $name = ($index->{index_unique} ? $unique_case_map{$name} : $index_case_map{$name}) || $name; + my $field = $col_case_map{lc $index->{index_column}} || $index->{index_column}; + if ($index->{index_primary}) { + push @pk, $field if $index->{index_primary}; + # Ignore primary indexes that we don't know about because pk's CAN + # overlap regular indexes in some databases + next unless exists $unique_case_map{$name} or exists $index_case_map{$name}; + } + if ($index->{index_unique}) { + push @{$unique{$name}}, $field; + } + else { + push @{$index{$name}}, $field; + } + } + + my $old_cols = $self->{table}->cols; + for my $col (keys %cols) { + for my $val (keys %{$old_cols->{$col}}) { + $cols{$col}->{$val} = $old_cols->{$col}->{$val} unless exists $cols{$col}->{$val}; + } + } + $self->{table}->cols(\%cols); + $self->{table}->pk(@pk); + $self->{table}->ai($ai || ''); + $self->{table}->index(\%index); + $self->{table}->unique(\%unique); + + return 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + require GT::SQL::Editor; +# Were ->{fk} there, Editor would wipe the current table from all fk_tables + my $fk = delete $self->{table}->{schema}->{fk}; + my $ret = GT::SQL::Editor->new( + debug => $self->{_debug}, + table => $self->{table}, + connect => $self->{table}->{connect} + )->drop_table(@_); + $self->{table}->{schema}->{fk} = $fk; + $ret; +} +END_OF_SUB + +## +# $obj->clear_schema +# ------------------ +# Resets the schema to an empty schema. +## +sub clear_schema { + my $self = shift; + + %{$self->{table}->{schema}} = ( + index => {}, + unique => {}, + cols => {}, + pk => [], + fk => {}, + subclass => {}, + ai => '', + fk_tables => [] + ); + $self->{table}->{search_driver} = 'NONINDEXED'; +} + +## +# $obj->cols($hash_ref); +# --------------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# -------------------------- +# Sets the relations columns as specified via method +# params. +## +sub cols { + my $self = shift; + return $self->{table}->cols(@_); +} + +## +# $obj->pk($array_ref); +# -------------------------- +# Sets relation primary key, $array_ref is the +# reference to an array which looks like +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# ------------------------------------- +# Sets relation primary key given the fields +# which are in parameter. +## +sub pk { + my $self = shift; + $self->{table}->pk(@_) or return; + return 1; +} + +## +# $obj->ai($column); +# ----------------------- +# Sets the AUTO INCRIMENT column. +## +sub ai { + my $self = shift; + $self->{table}->ai(@_) or return; + return 1; +} + +## +# $obj->name($table_name); +# ----------------------------- +# Sets the name for the table to create. +## +sub name { + my $self = shift; + $self->{table}->name(@_) or return; + return 1; +} + +## +# $obj->form_display($nice_name); +# ------------------------ +# Sets the name of the table as it is displayed +# using the Display module. +## +sub form_display { + my $self = shift; + $self->{table}->form_display(@_) or return; + return 1; +} + +## +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index( +# { +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# } +# ); +# ---------------------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +## +sub index { + my $self = shift; + $self->{table}->index(@_) or return; + return 1; +} + +## +# $obj->search_driver( $searching_driver ); +# -------------------------------------------------- +## +sub search_driver { + my $self = shift; + $self->{table}->search_driver(@_) or return; + return 1; +} + +## +# $obj->unique($index_name, $col1, ..., $coln); +# -------------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +## +sub unique { + my $self = shift; + $self->{table}->unique(@_) or return; + return 1; +} + +## +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_1, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ----------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME => { SOURCE_FIELD_1 => TARGET_FIELD }); +# -------------------------------------------------------------- +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +sub fk { + my $self = shift; + $self->{table}->fk(@_) or return; + return 1; +} + +sub subclass { return shift->{table}->subclass(@_) } + +## +# $obj->save_schema +# Saves the schema (.def) file. Useful when loading tables +# that already exist, but you don't want to overwrite. +## +sub save_schema { + return unless ($_[0]->{table}); + return $_[0]->{table}->save_state(); +} + +$COMPILE{_consolidate} = __LINE__ . <<'END_OF_SUB'; +sub _consolidate { +#------------------------------------------------------------------------------- + my $self = shift; + my $opts = shift; + my $long_name = $self->{table}->{name}; + my $table_name = $long_name; + my $prefix = $self->{connect}->{PREFIX}; + $table_name =~ s,^$prefix,,; + + my $file = "$self->{connect}->{def_path}/$long_name.def"; + +# $self->clear_schema(); + my $table = $self->{table}->table( $table_name ) or die $GT::SQL::error; + + $table->connect(); + my $source = $table->{schema}; + my $destination = $self->{table}->{schema}; + +# HANDLE COLUMNS + my $s_cols = $source->{cols}; + my $d_cols = $destination->{cols}; + +# special vars + my ( %POSITION, %CHANGED, %REMOVED, %ADDED ); + +# compare the table columns from source to destination + my ( $cols, %col_order ); + %col_order = map { $_ => $s_cols->{$_}->{'pos'} } keys %$s_cols; + + for my $col_name ( keys %col_order ) { + + if ( $d_cols->{$col_name} ) { + + if ( _is_different( $d_cols->{$col_name}, $s_cols->{$col_name} ) ) { + + for my $option ( %{$d_cols->{$col_name}} ) { + + my $d_opts = $d_cols->{$col_name}; + my $s_opts = $s_cols->{$col_name}; + + if ( $option eq 'pos' ) { + if ( $d_opts->{pos} != $s_opts->{pos} ) { + $POSITION{$col_name} = $d_opts; + }; + } + + elsif ( ref $d_opts->{$option} eq 'ARRAY' ) { + my $d_ar = $d_opts->{$option}; + my $s_ar = $s_opts->{$option}; + if ( @$d_ar != @$s_ar ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + else { + for my $index ( 0..( scalar(@$d_ar)-1 ) ) { + if ( $d_ar->[$index] != $s_ar->[$index] ) { + $CHANGED{$col_name} = $d_cols->{$col_name}; + } + } + } + } + + else { + ( $d_opts->{$option} ne $s_opts->{$option} ) and $CHANGED{$col_name} = $d_cols->{$col_name}; + } + + } + + } + + } + + else { + $REMOVED{$col_name} = $s_cols->{$col_name}; + }; + + } + +# compare the table columns from destination to source + %col_order = map { $_ => $d_cols->{$_}->{'pos'} } keys %$d_cols; + for my $col_name ( keys %col_order ) { + if ( !$s_cols->{$col_name} ) { + $ADDED{$col_name} = $d_cols->{$col_name}; + } + } + +# HANDLE INDEXES + my $d_idx = $destination->{index}; + my $s_idx = $source->{index}; + my %index_order = map { $_ => 1 } ( keys %$d_idx, keys %$s_idx ); + my %INDEXES = (); + for my $idx_name ( keys %index_order ) { + if ( $d_idx->{$idx_name} and $d_idx->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_idx->{$idx_name} || []}; + my $d_cols = join "|", sort @{$s_idx->{$idx_name} || []}; + if ( $s_cols ne $d_cols ) { + $INDEXES{$idx_name} = $d_idx->{$idx_name}; + } + else { + $INDEXES{$idx_name} = 'EQ'; + } + } + elsif ( !$d_idx->{$idx_name} and $s_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'REMOVED'; + } + elsif ( !$s_idx->{$idx_name} and $d_idx->{$idx_name} ) { + $INDEXES{$idx_name} = 'ADDED'; + } + } + +# HANDLE AUTOINCREMENT + my $AI = undef; + if ( $destination->{ai} eq $source->{ai} ) { + $AI = 'EQ'; + } + else { + $AI = $destination->{ai}; + } + +# HANDLE PK + my $PK = undef; + $d_cols = join "|", sort @{$destination->{pk} || []}; + $s_cols = join "|", sort @{$source->{pk} || []}; + if ( $d_cols eq $s_cols ) { + $PK = 'EQ'; + } + else { + $PK = $destination->{pk}; + } + +# HANDLE FK + my %FK = (); + my $d_fk = $destination->{fk}; + my $s_fk = $source->{fk}; + %index_order = map { $_ => 1 } ( keys %$d_fk, keys %$s_fk ); + for my $col_name ( keys %$d_fk ) { + if ( _is_different( $d_fk->{ $col_name }, $s_fk->{ $col_name } ) ) { + $FK{$col_name} = $s_fk->{ $col_name }; + } + else { + $FK{$col_name} = 'EQ'; + } + } + +# HANDLE SUBCLASS + my %SUBCLASS = (); + my $d_sc = $destination->{subclass}; + my $s_sc = $source->{subclass}; + %index_order = map { $_ => 1 } ( keys %$d_sc, keys %$s_sc ); + for my $key ( keys %index_order ) { + if ( _is_different( $d_fk->{ $key }, $s_fk->{ $key } ) ) { + $SUBCLASS{ $key } = $d_fk->{ $key } ; + } + else { + $SUBCLASS{ $key } = 'EQ'; + } + } + +# HANDLE UNIQUE + my $d_uni = $destination->{unique}; + my $s_uni = $source->{unique}; + my %unique_order = map { $_ => 1 } ( keys %$d_uni, keys %$s_uni ); + my %UNIQUE = (); + for my $idx_name ( keys %unique_order ) { + if ( $d_uni->{$idx_name} and $d_uni->{$idx_name} ) { + my $s_cols = join "|", sort @{$d_uni->{$idx_name}}; + my $d_cols = join "|", sort @{$s_uni->{$idx_name}}; + if ( $s_cols ne $d_cols ) { + $UNIQUE{$idx_name} = $d_uni->{$idx_name}; + } + else { + $UNIQUE{$idx_name} = 'EQ'; + } + } + elsif ( !$d_uni->{$idx_name} and $s_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'REMOVED'; + } + elsif ( !$s_uni->{$idx_name} and $d_uni->{$idx_name} ) { + $UNIQUE{$idx_name} = 'ADDED'; + } + }; + +# Summon callback if required + $opts->{callback} and ( &{$opts->{callback}}( $self, $table, \%POSITION, \%CHANGED, \%REMOVED, \%ADDED, \%INDEXES, $AI, $PK, \%SUBCLASS, \%UNIQUE ) or return ); + +# if position movements are required we must read all the data into a temp +# table first + my $DO_POSITION = 0; + $DO_POSITION = $self->_create_temp_table( $table ); + +# ... change columns drop the columns + my $sth = $table->do_query(qq!DROP TABLE $long_name!) or die $GT::SQL::error; + +# change the columns that have to be changed. + $self->create( 'force' ) or die $GT::SQL::error; + +# ... add the columns that have been removed in the past + if ( %REMOVED and $self->{carry_over_columns} ) { + my $editor = $self->{table}->editor($table_name); + my $pos = scalar( keys %{$destination->{cols}} ); + for my $col_name ( sort { $REMOVED{$a}->{pos} <=> $REMOVED{$b}->{pos} } keys %REMOVED ) { + $REMOVED{$col_name}->{pos} = ++$pos; + $editor->add_col( $col_name, $REMOVED{$col_name} ) or die $GT::SQL::error; + } + } + +# ... now copy the data over + $cols = $source->{cols}; + my $copy_cols = join ",", + sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } + grep { $self->{carry_over_columns} ? 1 : not $REMOVED{$_} } + keys %$cols; + $table->do_query(qq! + INSERT INTO $long_name + ($copy_cols) + SELECT $copy_cols + FROM $DO_POSITION + !) or die $GT::SQL::error; + + if ( %CHANGED ) { + my $editor = $self->{table}->editor($table_name); + for my $col_name ( keys %CHANGED ) { + $editor->alter_col( $col_name, $CHANGED{$col_name} ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_create_temp_table} = __LINE__ . <<'END_OF_SUB'; +sub _create_temp_table { +#------------------------------------------------------------------------------- +# + my $self = shift; + my $table = shift; + my $source = $table->{schema}; + my $def_path = $self->{connect}->{def_path}; + + use GT::MD5; + my $table_name = ''; + while ( -e ( $def_path . ( $table_name = GT::MD5::md5_hex( time() * rand() * 10000 ) ) ) ) {}; + my $c = $table->creator( $table_name ); + my $struct = _copy_struct( $source ); + $struct->{fk_tables} = {}; + $struct->{fk} = {}; + $struct->{subclass} = {}; + for ( values %{$struct->{cols}} ) { delete $_->{weight}; } + + $c->cols( %{$struct->{cols}} ); + %{$c->{table}->{schema}} = %$struct; + $c->create( "force" ) or die $GT::SQL::error; + + my $tbl = $table->table( $table_name ); + my $s_name = $table->name(); + my $d_name = $tbl->name(); + + $tbl->connect(); + $tbl->do_query(qq|INSERT INTO $d_name SELECT * FROM $s_name|) or die $GT::SQL::error; + + return $table_name; +} +END_OF_SUB + +$COMPILE{_copy_struct} = __LINE__ . <<'END_OF_SUB'; +sub _copy_struct { +#------------------------------------------------------------------------------- +# + my $source = shift; + my $copied_struct = undef; + + if ( ref $source eq 'HASH' ) { + $copied_struct = {}; + for my $key ( keys %$source ) { + $copied_struct->{ $key } = _copy_struct( $source->{$key} ); + } + } + + elsif ( ref $source eq 'ARRAY' ) { + $copied_struct = []; + for my $element ( @$source ) { + push @$copied_struct, _copy_struct( $element ); + } + } + + else { + $copied_struct = $source; + } + + return $copied_struct; +} +END_OF_SUB + + +$COMPILE{_is_different} = __LINE__ . <<'END_OF_SUB'; +sub _is_different { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return 1 } + + if ( ref $source eq 'HASH' ) { + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + for my $key ( keys %keys ) { + _is_different( $source->{$key}, $destination->{$key} ) and return 1; + } + } + + elsif ( ref $source eq 'ARRAY' ) { + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + my $count = ( $ca > $cb ) ? $ca : $cb; + for my $index ( 0 .. ( $count - 1 ) ) { + _is_different( $source->[$index], $destination->[$index] ) and return 1; + } + } + + else { + ( $source ne $destination ) and return 1; + } + + return; +} +END_OF_SUB + +$COMPILE{_compare} = __LINE__ . <<'END_OF_SUB'; +sub _compare { +#------------------------------------------------------------------------------- +# takes a hashref or arrayref and compares the two +# + my ( $source, $destination ) = @_; + + if ( ref $source ne ref $destination ) { return [ 'NE_TYPES', ref $source, ref $destination ]; } + + if ( ref $source eq 'HASH' ) { + return _comp_hash( $source, $destination ); + } + elsif ( ref $source eq 'ARRAY' ) { + return _comp_array( $source, $destination ); + } + else { + return; + } + +} +END_OF_SUB + +$COMPILE{_comp_hash} = __LINE__ . <<'END_OF_SUB'; +sub _comp_hash { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my %errs; + my %keys = map { $_ => 1 } ( keys %$source, keys %$destination ); + + for my $key ( keys %keys ) { + + my $src = $source->{$key}; + my $dst = $destination->{$key}; + if ( ref $src or ref $dst ) { + $errs{$key} = _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + $errs{$key} = 'EQ'; + } + else { + $errs{$key} = [ 'NE', $src, $dst ]; + } + + } + + return \%errs; +} +END_OF_SUB + +$COMPILE{_comp_array} = __LINE__ . <<'END_OF_SUB'; +sub _comp_array { +#------------------------------------------------------------------------------- + my ( $source, $destination ) = @_; + my @errs; + my $ca = scalar(@$source); + my $cb = scalar(@$destination); + + my $count = ( $ca > $cb ) ? $ca : $cb; + + for my $index ( 0 .. ( $count - 1 ) ) { + + my $src = $source->[$index]; + my $dst = $destination->[$index]; + if ( ref $src or ref $dst ) { + push @errs, _compare( $src, $dst ); + } + elsif ( $src eq $dst ) { + push @errs, 'EQ'; + } + else { + push @errs, [ 'NE', $src, $dst ]; + } + + } + + return \@errs; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Creator - an object to create SQL tables. + +=head1 SYNOPSIS + + my $creator = $DB->creator('Newtable'); + $creator->cols( + col1 => { + pos => 1 + type => 'CHAR', + size => 50 + }, + col2 => { + pos => 2, + type => 'INT', + not_null => 1 + } + ); + $creator->pk('col2'); + $creator->ai('col2'); + $creator->create or die "Unable to create: $GT::SQL::error"; + +=head1 DESCRIPTION + +A creator object is used to build new SQL tables. + +To get a new creator object, you need to call creator() from an existing +GT::SQL object. + +The object that is returned has methods to set up your table. You will need to +call this method for each table you want to create. + + $creator = $obj->creator($table); + +You must pass in the name of the table you want to create. This means if you +have a table named C you must call C<-Ecreator> with C<'MyTable'> +as the argument. + + $creator = $obj->creator('MyTable'); + +From this point you can call create methods on your creator object to define +and create your table. + +=head2 cols + +I is used to define the columns that will be in the new table by setting +properties such as the type, whether it allows null values, unsigned etc. + +For detailed information on the types and options accepted, please see +L. The following describes the options accepted that do not +directly affect the underlying database: + +=over 4 + +=item values + +This specifies the values for the I column type. If you are using an +I this must be set. The value for this should be an array reference of +the possible values for the I column. The values in the array that is +passed in will be quoted by DBI's quote method. + +=item regex + +This is a regex that the value must pass before being inserted +into the database. + +=item form_display + +This is a "pretty name" that will be used by the HTML module +for creating attractive forms automatically. + +=item form_size + +This is the form field length to be used by the HTML module. + +=item form_type + +This is the type of form to use by the HTML module: select, checkbox +radio, text, textarea or hidden. + +=item form_names + +This is for multi select or checkboxes and is an array ref of names +that get displayed. + +=item form_values + +This is for multi select or checkboxes and is an array ref of the +actual values that will be stored in the database. + +=item time_check + +This is only useful for TIMESTAMP fields. If set to 1, the module +will not allow you to update a record which has an older timestamp +then what is in the database. This is very helpful for protecting +against multiple updates. + +=item weight + +By giving an item a weight, GT::SQL will maintain a search index +table, and use that search index table when called using query. +This is only useful for indexing large text fields and should not +be used normally. The higher the weight, the more influence that +column will have on the result. So if a Title was set to weight +3 and a Description to weight 1, then when doing a search, a match +in the title would make the result appear before a match in the +description. + +=back + +So an example would look like: + + $creator->cols( + $col1 => { + type => 'ENUM', + values => ['val1', 'val2' ... ], + not_null => 1 + }, + $col2 => { + ... + } + ); + +Sets the relations columns as specified via method +parameters. The only required key for the has is type. +However some column types require other values be set +such as I requires you specify the values. + +=head2 pk + +C lets you specify the primary keys for the current table. +This method can be called with an array of primary key columns +in which case all the specified column names in the array will +make up the primary keys. If you call it with a single scalar +value this is assumed to be the primary key for the table. + + $creator->pk($field1, $field2, ...); + +=head2 ai + +This specifies the auto increment column for the current table. +There can be only one auto increment column per table, it must +be a numeric type, it must be not null and it must be the +primary key. This limitation is checked when you call create. +If it is not a numeric column type you will get a fatal error +when you call create. If any of the other limitations fail +the creator class will correct. + +=head2 index + +C allows you to specify the name and the columns for you +table indexes. + +There are two ways to call this method. + +You can set up all your indexes at once by calling it with +hash reference like this: + + $creator->index({ + $index1 => [field1, field2], + $index2 => [field3, field4] + }); + +The keys to this hash reference are the index names and +the values are an array reference containing the columns +that are part of the named index. The order for these +columns are maintained during the create. + +You can also pass in one index at a time like this; + + $creator->index($index_name, $col1, ..., $coln); + +The first argument is the name of the index and all the +rest are treated as columns that are part of this index. +Again the order of the columns are maintained. + +=head2 unique + +The C method allows you to specify the unique +indexes for the current table. This method takes the +same arguments as the C method. + +=head2 fk + +C allows you to specify foreign key relations for your +tables. You CAN NOT specify foreign keys for tables that +have not been created yet. There are two ways to pass in +arguments to C. The first way is passing in a hash reference. + + $creator->fk({ + $FOREIGN_TABLE_NAME => + { + $LOCAL_TABLE_COL_1 => $FOREIGN_TABLE_COL_1, + ... + $LOCAL_TABLE_COL_n => $FOREIGN_TABLE_COL_n + } + }); + +The keys to the hash are the names of the tables you are relating to. +The values are a hash reference that contain the name of the current +tables columns as the keys and the name of the foreign tables columns +that we are relating to as the values. + +You cannot relate fields to your self. You also need to be careful +not to create circular references. This is checked when you call this +method. If there is a circular reference detected you will receive a +fatal error. + +Foreign keys currently effect selects only. + +=head2 search_driver + +This affects how the weighted records are indexed. By default the +system will attempt to use best driver for the DBMS. However, if +you'd like to force the indexing system to an alternative type, such +as for MYSQL you can use this. + +* note: though the MYSQL driver is faster, the internal indexing system +has better support for phrase searching and keyword searching. + +To set the driver, call C with the appropriate driver +name. The following example will force the system into using the +internally implemented indexing scheme. + + $creator->search_driver('INTERNAL'); + +Currently, the only other valid option is "MYSQL". + +-note- + +The MYSQL driver occasionally behaves oddly with a small number of +records. In that case, set the search scheme to "INTERNAL". + +=head2 create + +This is the method you call to create your table after you have specified +all your table definitions. Several checks are made when this method is +called to ensure the table is created correctly. + +One of the things that is done is checking to see that the table you are +trying to create does not exist. If the table does exist I will +return undefined and set the error in $GT::SQL::error. + +You can specify to have C drop the table by passing in "force". + + $creator->create('force'); + +-or- + + $creator->create; + +C returns true on success and undef on failure. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML.pm new file mode 100644 index 0000000..c0ccde0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML.pm @@ -0,0 +1,893 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Display::HTML +# Author: Scott & Alex +# $Id: HTML.pm,v 1.98 2009/03/23 22:55:53 brewt 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.98 $ =~ /(\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' ) { + for (qw/_filename _del/) { + $values->{$col.$_} = $self->{values}->{$col.$_} if exists $self->{values}->{$col.$_}; + } + } + $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~~; +} + +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="multiple" size="$self->{cols}->{$clean_name}->{form_size}"!; + } + elsif (exists $opts->{multiple} and $opts->{multiple} > 1) { + $mult = qq! multiple="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}) ? qq| class="$opts->{def}->{class}"| : ""; + my $out = qq~~; + $blank and ($out .= qq~~); + +# 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~"; + } + $out .= "\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}) ? qq| 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 ~) and next KEY; + } + $out .= qq~$val ~; + } + 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}) ? qq| 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~) and next KEY; + } + $out .= qq~ $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~~; +} + +sub hidden_text { + my ($self, $opts) = @_; + my $out; + my $html = $self->_get_html_display; + $out .= "{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~~; + 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]} }); + + my $use_path = $self->{file_use_path} && -e $opts->{value}; + if ($use_path or $href) { + + require GT::SQL::File; + my $sfname = $values->{$colname."_filename"}; + $out = $sfname || GT::SQL::File->get_filename($fname ||= $href->{File_Name}); + $use_path and $out .= qq!!; + $sfname and $out .= qq!!; + + 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 => $use_path ? 'path' : 'db', + fname => $fname + }, + [qw( do id cn db src )] + ); + $out .= qq! {font}>download!; + $url = _reparam_url( + $self->{url}, + { + do => 'view_file', + id => $values->{$pk[0]}, + cn => $colname, + db => $dbname, + src => $use_path ? 'path' : 'db', + fname => $fname + }, + [qw( do id cn db src )] + ); + $out .= qq! {font}>view!; + } + my $checked = $values->{"${colname}_del"} ? ' checked="checked" ' : ''; + $out .= qq~ Delete~; + } + } + my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : ""; + $out .= qq~~; + + 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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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}) ? qq| class="$opts->{def}->{class}"| : ""; + return qq~~; +} + +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 .= "
        "; + } + } + } + + 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}>download!; + + $url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] ); + $val .= qq! {font}>view!; + } + + 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~[<<] ~); + ($nh > 1) and ($url .= qq~[<] ~); + 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~$i ~); + if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; } + } + $url .= qq~[>] ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits)); + $url .= qq~[>>] ~ 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', '=', '<>', '>', '<' ], + $val ||= '=', 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; + return unless $$t; + $$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. diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Relation.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Relation.pm new file mode 100644 index 0000000..e549e59 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Relation.pm @@ -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 .= '
        '; + + 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~~; + } + $self->{extra_table} and ($out .= "\n"); + return $out; +} + +sub mk_table { + my $self = shift; + my %opt = @_; + + my $out = ''; + $self->{extra_table} and ($out .= "

        "); + my $cols = $opt{table}->cols; + my $name = $opt{table}->name; + + $out .= qq( + {table}> + + ); + 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 .= "
        + $name +
        \n"; + $out .= "

        \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}>{td} width='$opt{cwidth}'>{col_font}>$display_name{td} width='$opt{vwidth}'>{val_font}>"; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self ); + + $out .= ""; + +# 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} width="10%">{val_font}>~; + $out .= $self->_mk_search_opts({ + name => $field_name, + def => $self->{cols}->{$col}, + pk => $is_pk + }) || ' '; + $out .= ""; + } + $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 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Table.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Table.pm new file mode 100644 index 0000000..507196a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Display/HTML/Table.pm @@ -0,0 +1,299 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Display::HTML +# Author: Scott & Alex +# $Id: Table.pm,v 1.29 2009/05/11 23:09:59 brewt 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.29 $ =~ /(\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 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{col_font}>!; + $out .= 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" ) : '' ) . ""; + $out .= qq!\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, $col); + 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{col_font}>!; + +# Get the column display subroutine + $out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }); + + $out .= qq!\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 .= "
        "); + $out .= "{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 (ref $self->{code}->{$col} eq 'CODE') { + $out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values, $col); + 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}>"; + +# Display any search options if requested. + if ($self->{search_opts}) { + $out .= qq~"; + } + $out .= "\n"; + } + $out .= "
        {td} width='$cwidth'>{col_font}>$display_name{td} width='$vwidth'>{val_font}>"; + +# Get the column display subroutine + my $o = $self->$disp( + { + name => $field_name, + def => $self->{cols}->{$col}, + value => (defined $value ? $value : '') + }, + ($values || {}), + $self + ); + $out .= $o if defined $o; + +# Add edit/delete links next to the primary key in search results. + if ($self->{mode} eq 'search_results' and @{$self->{pk}} == 1 and $col eq $self->{pk}->[0]) { + my $url = GT::CGI->url({ query_string => 0 }) . '?'; + my @vals = GT::CGI->param('db'); + for my $val (@vals) { + $url .= 'db=' . GT::CGI->escape($val) . ';'; + } + chop $url; + $out .= qq| edit delete|; + } + $out .= "{td} width="10%">{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 .= "
        \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~~; + } + $self->{extra_table} and ($out .= "
        \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 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver.pm new file mode 100644 index 0000000..e9c128c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver.pm @@ -0,0 +1,904 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver +# CVS Info : 087,071,086,086,085 +# $Id: Driver.pm,v 2.6 2005/11/03 01:38:30 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.6 $ =~ /(\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, '?'; + + # If the column is numeric, make sure a '' becomes a null, due to + # problems where old libraries or the table editor could have set the + # default to '': + if (defined $val and $val eq '' and $cols->{$col}->{type} =~ /^(?:INTEGER|REAL|FLOAT|DOUBLE|DECIMAL)$|INT$/) { + $val = undef; + } + 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MSSQL.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MSSQL.pm new file mode 100644 index 0000000..6891d2a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MSSQL.pm @@ -0,0 +1,522 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::MSSQL +# CVS Info : 087,071,086,086,085 +# $Id: MSSQL.pm,v 2.7 2005/12/03 00:54:11 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 <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(<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 < 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. Actually, we look for 4000 because that's + # the worst-case scenario for escaping being able to increase to 8000 characters. + for (my $i = 0; $i < @_; $i++) { + if (defined $_[$i] and length $_[$i] > 4000) { + $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/
        /\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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MYSQL.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MYSQL.pm new file mode 100644 index 0000000..b54dd80 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/MYSQL.pm @@ -0,0 +1,226 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::MYSQL +# CVS Info : 087,071,086,086,085 +# $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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/ORACLE.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/ORACLE.pm new file mode 100644 index 0000000..1abcd0a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/ORACLE.pm @@ -0,0 +1,590 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::ORACLE +# CVS Info : 087,071,086,086,085 +# $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao 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; + # using ROWNUM to limit rows instead. + my $max_rows = $offset + $limit; + $query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $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(<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 <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/
        /\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}) { + while (my $rec = $self->{sth}->fetchrow_arrayref) { + my @tmp = @$rec; + pop @tmp; # get rid of the RNUM extra column + push @{$self->{_results}}, [@tmp]; # 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; +} + +$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _fetchrow_hashref { +# ----------------------------------------------------------------------------- +# Handles row fetching for driver that can't use the default ->fetchrow_hashref +# due to needing column case mapping ($sth->{hints}->{case_map}), or special +# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit +# handling). +# + my $self = shift; + + my %case_map; # returnedname => ReturnedName, but only for columns that use upper case + if ($self->{hints}->{case_map}) { + if (exists $self->{schema}->{cols}) { + my $cols = $self->{schema}->{cols}; + %case_map = map { lc $_ => $_ } keys %$cols; + } + else { + for my $table (keys %{$self->{schema}}) { + for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) { + $case_map{lc $col} = $col; + } + } + } + } + + if ($self->{_results}) { + my $arr = shift @{$self->{_results}} or return; + + my $i; + my %selected = map { lc $_ => $i++ } @{$self->{_names}}; + my %hash; + + for my $lc_col (keys %selected) { + next if $lc_col eq 'rnum'; + if (exists $case_map{$lc_col}) { + $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}]; + } + else { + $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}]; + } + } + return \%hash; + } + else { + my $h = $self->{sth}->fetchrow_hashref or return; + for (keys %$h) { + $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_}; + } + return $h; + } +} +END_OF_SUB + +# ----------------------------------------------------------------------------- +# 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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/PG.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/PG.pm new file mode 100644 index 0000000..93432ee --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/PG.pm @@ -0,0 +1,661 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::PG +# CVS Info : 087,071,086,086,085 +# $Id: PG.pm,v 2.3 2005/10/06 00:05:51 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: PostgreSQL driver for GT::SQL +# + +package GT::SQL::Driver::PG; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; +use DBI(); + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver/; + +sub protocol_version { 2 } + +sub connect { + my $self = shift; + my $dbh = $self->SUPER::connect(@_) or return; + + # This is really a hack to get things working somewhat accurately - ideally + # all data should be in UTF8, but GT::SQL and our products do not yet have + # any provision for such, and inserting iso8859-1 data into a unicode table + # causes fatal errors about invalid utf8 sequences. So, we set it to + # latin1 here in the hopes that it won't break too much, and let the + # application deal with it. There are still inherent problems here, + # however - if the database is latin5, for example, setting this to latin1 + # would make postgresql attempt to convert from latin1 -> latin5 on input + # and convert back on output, which is a potentially lossy conversion. + $dbh->do("SET NAMES 'LATIN1'"); + + return $dbh; +} + +sub dsn { +# ----------------------------------------------------------------------------- +# Creates a postgres-specific DSN, such as: +# DBI:Pg:dbname=database;host=some_hostname +# host is omitted if set to 'localhost', so that 'localhost' can be used for a +# non-network connection. If you really want to connect to localhost, use +# 127.0.0.1. +# + my ($self, $connect) = @_; + + $connect->{driver} ||= 'Pg'; + $connect->{host} ||= 'localhost'; + $self->{driver} = $connect->{driver}; + + my $dsn = "DBI:$connect->{driver}:"; + $dsn .= "dbname=$connect->{database}"; + $dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost'; + $dsn .= ";port=$connect->{port}" if $connect->{port}; + + return $dsn; +} + +sub hints { + prefix_indexes => 1, + fix_index_dbprefix => 1, + case_map => 1, + ai => sub { + my ($table, $column) = @_; + my $seq = "${table}_seq"; + my @q; + push @q, \"DROP SEQUENCE $seq"; + push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1"; + \@q; + }, + drop_pk_constraint => 1 +} + +$COMPILE{_version} = __LINE__ . <<'END_OF_SUB'; +sub _version { + my $self = shift; + return $self->{pg_version} if $self->{pg_version}; + my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION + if ($ver) { + local $^W; + $ver = sprintf "%.2f", $ver; + } + return $self->{pg_version} = $ver; +} +END_OF_SUB + +sub _prepare_select { +# ----------------------------------------------------------------------------- +# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format +# + my ($self, $query) = @_; + $query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i; + $query; +} + +sub _prepare_describe { +# ------------------------------------------------------------------ +# Postgres-specific describe code +# + my ($self, $query) = @_; + $query =~ /DESCRIBE\s*(\w+)/i + or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query"); + + # atttypmod contains the scale and precision, but has to be extracted using bit operations: + my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000) + my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000) + + <>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')' + ELSE t.typname + END AS "Type", + CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null", + ( + SELECT + CASE + WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#') + WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc + ELSE NULL + END + FROM pg_attrdef + WHERE adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Default", + ( + SELECT + CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END + FROM pg_attrdef d + WHERE d.adrelid = c.relfilenode AND adnum = a.attnum + ) AS "Extra" +FROM + pg_class c, pg_attribute a, pg_type t +WHERE + a.atttypid = t.oid AND a.attrelid = c.oid AND + relkind = 'r' AND + a.attnum > 0 AND + c.relname = '\L$1\E' +ORDER BY + a.attnum +QUERY + +# The following could be used above for Key - but it's left off because SHOW +# INDEX is much more useful: +# ( +# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END +# FROM pg_index keyi, pg_class keyc, pg_attribute keya +# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid +# and indisprimary = 't' and keya.attname = a.attname +# ) AS "Key", +} + +sub column_exists { + my ($self, $table, $column) = @_; + my $sth = $self->{dbh}->prepare(< 0 AND + c.relname = ? AND a.attname = ? +EXISTS + $sth->execute(lc $table, lc $column); + + return scalar $sth->fetchrow; +} + +sub _prepare_show_tables { +# ----------------------------------------------------------------------------- +# pg-specific 'SHOW TABLES'-equivelant +# + <<' QUERY'; + SELECT relname AS tables + FROM pg_class + WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%') + ORDER BY relname + QUERY +} + +sub _prepare_show_index { +# ----------------------------------------------------------------------------- +# Get index list +# + my ($self, $query) = @_; + unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) { + return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query"); + } + <<" QUERY"; + SELECT + c.relname AS index_name, + attname AS index_column, + CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique, + CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary + FROM + pg_index i, + pg_class c, + pg_class t, + pg_attribute a + WHERE + i.indexrelid = c.oid AND + a.attrelid = c.oid AND + i.indrelid = t.oid AND + t.relname = '\L$1\E' + ORDER BY + i.indexrelid, a.attnum + QUERY +} + +sub drop_table { +# ----------------------------------------------------------------------------- +# Drops the table passed in - drops a sequence if needed. Takes a second +# argument that, if true, causes the sequence _not_ to be dropped - used when +# the table is being recreated. +# + my ($self, $table) = @_; + + my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'"); + $sth->execute(); + if (my $seq_name = $sth->fetchrow) { + $self->do("DROP SEQUENCE $seq_name") + or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error); + } + return $self->SUPER::drop_table($table); +} + +sub drop_column { +# ------------------------------------------------------------------- +# Drops a column from a table. +# + my ($self, $table, $column) = @_; + + my $ver = $self->_version(); + + # Postgresql 7.3 and above support ALTER TABLE $table DROP $column + return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03; + + $self->_recreate_table(); +} + +$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB'; +sub _recreate_table { +# ----------------------------------------------------------------------------- +# Adds/removes/changes a column, but very expensively as it involves recreating +# and copying the entire table. Takes argument pairs, currently: +# +# with => 'adding_this_column' # optional +# +# Keep in mind that the various columns depend on the {cols} hash of the table +# having been updated to reflect the change. +# +# We absolutely require DBI 1.20 in this subroutine for transaction support. +# However, we won't get here if using PG >= 7.3, so you can have either an +# outdated PG, or an outdated DBI, but not both. +# + my ($self, %opts) = @_; + + DBI->require_version(1.20); + my $ver = $self->_version; + + my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified'); + + my $cols = $self->{schema}->{cols}; + my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols; + + my (@copy_cols, @select_cols); + for (keys %$cols) { + push @copy_cols, "$_ " . $self->column_sql($cols->{$_}); + push @select_cols, $_; + } + + if ($opts{with}) { # a column was added, so we can't select it from the old table + @select_cols = grep $_ ne $opts{with}, @select_cols; + } + + $self->{dbh}->begin_work; + + my $temptable = "GTTemp" . substr(time, -4) . int rand 10000; + my $select_cols = join ', ', @select_cols; + my $lock = "LOCK TABLE $table"; + my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table"; + + my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable"; + my $drop_temp = "DROP TABLE $temptable"; + + for my $precreate ($lock, $createtemp) { + unless ($self->{dbh}->do($precreate)) { + $self->warn(CANTEXECUTE => $precreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + unless ($self->drop_table($table)) { + $self->{dbh}->rollback; + return undef; + } + + unless ($self->create_table) { + $self->{dbh}->rollback; + return undef; + } + + for my $postcreate ($insert, $drop_temp) { + unless ($self->{dbh}->do($postcreate)) { + $self->warn(CANTEXECUTE => $postcreate => $DBI::errstr); + $self->{dbh}->rollback; + return undef; + } + } + + $self->{dbh}->commit; + + return 1; +} +END_OF_SUB + +sub alter_column { +# ----------------------------------------------------------------------------- +# Changes a column in a table. The actual path done depends on multiple +# things, including your version of postgres. The following are supported +# _without_ recreating the table; anything more complicated requires the table +# be recreated via _recreate_table(). +# +# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20, +# everything else does) +# - adding/dropping a not null contraint, with >= 7.3 +# - any other changes, with >= 7.3, by adding a new column, copying data into +# it, dropping the old column +# +# Anything else calls _recreate_table(), which also requires DBI 1.20, but is +# much more involved as the table has to be dropped and recreated. +# + my ($self, $table, $column, $new_def, $old_col) = @_; + + my $ver = $self->_version; + return $self->_recreate_table() if $ver < 7; + + my $cols = $self->{schema}->{cols}; + my $new_col = $cols->{$column}; + + my @onoff = qw/not_null/; # true/false attributes + my @changeable = qw/default size scale precision/; # changeable attributes + my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff; + my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff; + my %change = map { ( + exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new + and ( + defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't + or + defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but != + ) + ) ? ($_ => 1) : () } @changeable; + + { + my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable; + my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable; + %add = (%add, %add_changeable); + %rem = (%rem, %rem_changeable); + } + + if ($ver < 7.03) { + # In 7.0 - 7.2, defaults can be added/dropped/changed, but anything + # more complicated needs a table recreation + if ( + keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default + or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default + or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default + ) { + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + my $ph; + if ($add{default} or $change{default}) { + $query .= "SET DEFAULT ?"; + $ph = $new_col->{default}; + } + else { + $query .= "DROP DEFAULT"; + } + $self->{dbh}->do($query, defined $ph ? (undef, $ph) : ()) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + return $self->_recreate_table(); + } + + # PG 7.3 or later + + if ( + keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL + or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL + ) { + # All we're doing is changing a not_null constraint + my $query = "ALTER TABLE $table ALTER COLUMN $column "; + $query .= $rem{not_null} ? 'DROP' : 'SET'; + $query .= ' NOT NULL'; + $self->{dbh}->do($query) + or return $self->warn(CANTEXECUTE => $query => $DBI::errstr); + return 1; + } + + if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8) + and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null + and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null + ) { + my @query; + # Change type (PG 8+ only) + if ($ver >= 8 and $change{type}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}"; + } + + # Change default + if ($add{default} or $change{default}) { + push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}]; + } + elsif ($rem{default}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT"; + } + + # Change not_null + if ($rem{not_null}) { + push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL"; + } + elsif ($add{not_null}) { + if ($add{default}) { + push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}]; + } + push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"; + } + + return $self->do_raw_transaction(@query); + } + + # We've got more complex changes than PG's ALTER COLUMN can handle; we need + # to add a new column, copy the data, drop the old column, and rename the + # new one to the old name. + my (@queries, %index, %unique); + + push @queries, "LOCK TABLE $table"; + my %add_def = %$new_col; + my $not_null = delete $add_def{not_null}; + my $default = delete $add_def{default}; + my $add_def = $self->column_sql(\%add_def); + my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000); + push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def"; + push @queries, "UPDATE $table SET $tmpcol = $column"; + push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default; + push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default; + push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null; + push @queries, "ALTER TABLE $table DROP COLUMN $column"; + push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column"; + + for my $type (qw/index unique/) { + while (my ($index, $columns) = each %{$new_col->{$type}}) { + my $recreate; + for (@$columns) { + if ($_ eq $column) { + $recreate = 1; + last; + } + } + next unless $recreate; + if ($type eq 'index') { + $index{$index} = $columns; + } + else { + $unique{$index} = $columns; + } + } + } + + $self->do_raw_transaction(@queries); + + while (my ($index, $columns) = each %index) { + $self->create_index($table, $index, @$columns); + } + while (my ($index, $columns) = each %unique) { + $self->create_unique($table, $index, @$columns); + } + + 1; +} + +sub add_column { +# ----------------------------------------------------------------------------- +# Adds a new column to the table. +# + my ($self, $table, $column, $def) = @_; + +# make a copy so the original reference doesn't get clobbered + my %col = %{$self->{schema}->{cols}->{$column}}; + +# Defaults and not_null have to be set _after_ adding the column. + my $default = delete $col{default}; + my $not_null = delete $col{not_null}; + + my $ver = $self->_version; + + return $self->_recreate_table(with => $column) + if $ver < 7 and defined $default or $ver < 7.03 and $not_null; + + my @queries; + + if (defined $default or $not_null) { + $def = $self->column_sql(\%col); + } + + push @queries, ["ALTER TABLE $table ADD $column $def"]; + + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default; + push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null; + push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null; + + $self->do_raw_transaction(@queries); +} + +sub create_pk { + my ($self, $table, @cols) = @_; + my $ver = $self->_version; + if ($ver < 7.2) { + return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")"); + } + else { + # ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior + # versions we have to recreate the entire table. + return $self->_recreate_table(); + } +} + +sub drop_pk { +# ----------------------------------------------------------------------------- +# Drop a primary key. Look for the primary key, then call drop_index with it. +# + my ($self, $table) = @_; + + my $sth = $self->prepare("SHOW INDEX FROM $table") or return; + $sth->execute or return; + my $pk_name; + while (my $index = $sth->fetchrow_hashref) { + if ($index->{index_primary}) { + $pk_name = $index->{index_name}; + last; + } + } + + $pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table"); + + $self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name"); +} + +sub ai_insert { + my ($self, $ai) = @_; + return $ai, "NEXTVAL('$self->{name}_seq')"; +} + +sub insert_multiple { +# ----------------------------------------------------------------------------- +# Performs multiple insertions in a single transaction, for much better speed. +# + my $self = shift; + + # ->begin_work and ->commit were not added until 1.20 + return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20; + + $self->{dbh}->begin_work; + my ($cols, $args) = @_; + + my $names = join ",", @$cols, $self->{schema}->{ai} || (); + + my $ret; + my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef; + + my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')'; + my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query); + for (@$args) { + if ($sth->execute(@$_)) { + ++$ret; + } + else { + $self->warn(CANTEXECUTE => $query); + } + } + $self->{dbh}->commit; + $ret; +} + +sub quote { +# ----------------------------------------------------------------------------- +# This subroutines quotes (or not) a value. Postgres can't handle any text +# fields containing null characters, so this has to go beyond the ordinary +# quote() in GT::SQL::Driver by stripping out null characters. +# + my $val = pop; + return 'NULL' if not defined $val; + return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val =~ y/\x00//d; + (values %GT::SQL::Driver::CONN)[0]->quote($val); +} + +package GT::SQL::Driver::PG::sth; +# ==================================================================== +use strict; +use vars qw/@ISA $ERROR_MESSAGE/; +use GT::SQL::Driver; +use GT::AutoLoader; + +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw/GT::SQL::Driver::sth/; + +sub insert_id { +# ------------------------------------------------------------------- +# Retrieves the current sequence. +# + my $self = shift; + my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i; + $table ||= $self->{name}; + + my $query = "SELECT CURRVAL('${table}_seq')"; + 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; + + return $id; +} + +# ------------------------------------------------------------------------------------------------ # +# DATA TYPE MAPPINGS +# ------------------------------------------------------------------------------------------------ # +package GT::SQL::Driver::PG::Types; +# =============================================================== +use strict; +use GT::SQL::Driver::Types; +use Carp qw/croak/; +use vars qw/@ISA/; +@ISA = 'GT::SQL::Driver::Types'; + +sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') } +sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') } +sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" } + +# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big) +# caveat to this type, however, is that it requires escaping for any input, and +# unescaping for any output. + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/Types.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/Types.pm new file mode 100644 index 0000000..78e8965 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/Types.pm @@ -0,0 +1,191 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::Types +# CVS Info : 087,071,086,086,085 +# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Implements subroutines for each type to convert into SQL string. +# See GT::SQL::Types for documentation +# +# Supported types are: +# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits +# REAL FLOAT DOUBLE - 32, 32, 64 bits +# DECIMAL - decimal precision +# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc. +# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space +# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type +# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively +# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes +# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons. +# FILE - GT::SQL pseudo-type + +package GT::SQL::Driver::Types; +use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/; +use strict; +use Exporter(); +use GT::Base(); + +*import = \&Exporter::import; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = 'GT::Base'; + +$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/; +@EXPORT_OK = qw/base/; + +sub base { +# ------------------------------------------------------------------ +# Base function takes care of most of the types that don't require +# much special formatting. +# + my ($class, $args, $name, $attribs) = @_; + $attribs ||= []; + my $out = $name; + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + $out; +} + +# Integers. None of the following are supported by Oracle, which can only +# define integer types by the number of digits supported (see +# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by +# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned +# attribute is also passed in). All int types are signed - an 'unsigned' +# column attribute can be used to /suggest/ that the integer type be unsigned - +# but it is only for some databases and/or INT types, and so not guaranteed. +sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int +sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int +sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int +sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int +sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int + +sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above + +# Floating point numbers +sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision) +sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks +sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL + +sub DECIMAL { +# ------------------------------------------------------------------ +# Takes care of DECIMAL's precision. +# + my ($class, $args, $out, $attribs) = @_; + $out ||= 'DECIMAL'; + $attribs ||= []; + + # 'scale' and 'precision' are the proper names, but a prior version used + # the unfortunate 'display' and 'decimal' names, which have no relevant + # meaning in SQL. + my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef; + my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef; + + $scale ||= 0; + $precision ||= 10; + + $out .= "($precision, $scale)"; + + for my $attrib (@$attribs) { + $out .= ' ' . $attrib if $args->{$attrib}; + } + defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}); + $args->{not_null} and $out .= ' NOT NULL'; + return $out; +} + +# Dates - just about every database seems to do things differently here. +sub DATE { $_[0]->base($_[1], 'DATE') } +sub DATETIME { $_[0]->base($_[1], 'DATETIME') } +sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') } +sub TIME { $_[0]->base($_[1], 'TIME') } +sub YEAR { $_[0]->base($_[1], 'YEAR') } + +# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255. +# Everything except Oracle handles VARCHAR's - Oracle, having deprecated +# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY' +# attribute to turn this into a "binary" char (meaning, really, +# case-insensitive, not binary) - for everything else, a "binary" argument is +# simply ignored. +sub CHAR { + my ($class, $args, $out) = @_; + # Important the set the size before calling BINARY, because BINARY's + # behaviour is different for sizes <= 255. + $args->{size} = 255 unless $args->{size} and $args->{size} <= 255; + +# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR + $out ||= 'VARCHAR'; + $out .= "($args->{size})"; + + $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default}; + $out .= ' NOT NULL' if $args->{not_null}; + return $out; +} +sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') } + +# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to +# provide different types based on the 'size' attribute. +sub TEXT { + my ($class, $attrib) = @_; + $class->base($attrib, 'TEXT') +} + +# .+TEXT is for compatibility with old code, and should be considered +# deprecated. Takes the args hash and the size desired. +sub _OLD_TEXT { + my ($class, $args, $size) = @_; + $args = {$args ? %$args : ()}; + $args->{size} = $size unless $args->{size} and $args->{size} < $size; + $class->TEXT($args); +} +sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) } +sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) } +sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) } +sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) } + +# The BLOB* columns below are heavily deprecated - they're still here just in +# case someone is still using them. Storing binary data inside an SQL row is +# generally a poor idea; a much better approach is to store a pointer to the +# data (such as a filename) in the database, and the actual data in a file. +# +# As such, the default behaviour is to fatal if BLOB's are used - only drivers +# that supported BLOB's prior to protocol v2 should override this. Should a +# binary type be desired in the future, a 'BINARY' pseudo-type is recommended. +sub BLOB { + my ($driver) = $_[0] =~ /([^:]+)$/; + $driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver; + $_[0]->fatal(DRIVERTYPE => $driver => 'BLOB') +} +sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') } +sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') } +sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') } + +# Enums - a non-standard SQL type implemented only by MySQL - the default +# implementation is to implement it as a CHAR (or TEXT if the longest value is +# more than 255 characters - but in that case, are you really sure you want to +# use this type?) +sub ENUM { + my ($class, $args) = @_; + my $max = 0; + @{$args->{'values'}} or return; + for my $val (@{$args->{'values'}}) { + my $len = length $val; + $max = $len if $len > $max; + } + my $meth = $max > 255 ? 'TEXT' : 'CHAR'; + $class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} }); +} + +# File handling +sub FILE { + my ($class, $args) = @_; + $class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} }); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/debug.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/debug.pm new file mode 100644 index 0000000..fe2e264 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/debug.pm @@ -0,0 +1,189 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::debug +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# GT::SQL::Driver debugging module +# + +package GT::SQL::Driver::debug; +use strict; + +use strict; +use GT::AutoLoader; +use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/; +@ISA = qw(GT::Base); +$QUERY_STACK_SIZE = 100; + +$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB'; +sub last_query { +# ------------------------------------------------------------------- +# Get, or set the last query. +# + my $self = shift; + return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug}); + + @_ > 0 or return $LAST_QUERY || ''; + + $LAST_QUERY = shift; + $LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_); + +# Display stack traces if requested via debug level. + my $stack = ''; + if ($self->{_debug} > 2) { + ($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY); + } + elsif ($self->{_debug} > 1) { + package DB; + my $i = 2; + my $ls = defined $ENV{REQUEST_METHOD} ? '
        ' : "\n"; + my $spc = defined $ENV{REQUEST_METHOD} ? ' ' : ' '; + 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; + $stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!; + } + else { + $stack .= qq!$sub called at $file line $line with no arguments.$ls!; + } + } + } + push @QUERY_STACK, $LAST_QUERY; + push @STACK_TRACE, "
        \n" . $stack . "\n
        \n" if ($self->{_debug} and $stack); + +# Pesistance such as Mod_Perl + @QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK; + @STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE; + + return $LAST_QUERY || ''; +} +END_OF_SUB + +$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB'; +sub js_stack { +# ------------------------------------------------------------------- +# Create a nicely formatted javascript browser that (unfortunately) +# only works in ie, netscape sucks. +# + my ($sp, $title) = @_; + + my $nb = @QUERY_STACK; + my ($stack, $dump_out); + { + package DB; + require GT::Dumper; + my $i = 0; + + while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) { + if (@DB::args) { + $args = "with arguments
           "; + my @args; + for (@DB::args) { + eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference + my $print = $@ ? \$_ : $_; + my $arg = defined $print ? $print : '[undef]'; + + $args .= "$arg, "; + my $dump = GT::Dumper::Dumper($arg); + $dump_out .= qq~ + +Top +
        $dump
        + ~; + $i++; + } + chop $args; chop $args; + } + else { + $args = "with no arguments"; + } + $stack .= qq!
      • $sub called at $file line $line $args.
      • \n!; + } + } + $stack =~ s/\\/\\\\/g; + $stack =~ s/[\n\r]+/\\n/g; + $stack =~ s/'/\\'/g; + $stack =~ s,script,sc'+'ript,g; + + $dump_out =~ s/\\/\\\\/g; + $dump_out =~ s/[\n\r]+/\\n/g; + + $dump_out =~ s/'/\\'/g; + $dump_out =~ s,script,sc'+'ript,g; + + my $var = < +function my$nb () { + msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes'); + msg.document.write('STACK TRACE
          $stack
        $dump_out'); + msg.document.close(); +} +HTML + my $link = qq!$title
        !; + + return $var, $link; +} +END_OF_SUB + +$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB'; +sub quick_quote { +# ------------------------------------------------------------------- +# Quick quote to replace ' with \'. +# + my $str = shift; + defined $str and ($str eq "") and return "''"; + $str =~ s/'/\\'/g; + return $str; +} +END_OF_SUB + +$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB'; +sub replace_placeholders { +# ------------------------------------------------------------------- +# Replace question marks with the actual values +# + my ($self, $query, @args) = @_; + if (@args > 0) { + my @vals = split /('(?:[^']+|''|\\')')/, $query; +# Keep track of where we are in each of the @vals strings so that strings with +# '?'s in them that aren't placeholders don't incorrectly get replaced with +# values. + my @vals_idx; + VALUE: for my $val (@args) { + SUBSTRING: for my $i (0 .. $#vals) { + next SUBSTRING if $i % 2; + $vals_idx[$i] ||= 0; + $vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]); + if ($vals_idx[$i] >= 0) { + $val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL'; + substr($vals[$i], $vals_idx[$i], 1, $val); + $vals_idx[$i] += length $val; + next VALUE; + } + else { + $vals_idx[$i] = 0; + } + } + } + $query = join '', @vals; + } + return $query; +} +END_OF_SUB + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/sth.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/sth.pm new file mode 100644 index 0000000..b4efbf9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/sth.pm @@ -0,0 +1,296 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Driver::sth +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# Generic statement handle wrapper +# + +package GT::SQL::Driver::sth; +use strict; +use GT::Base; +use GT::AutoLoader(NEXT => '_AUTOLOAD'); +require GT::SQL::Driver; +use GT::SQL::Driver::debug; +use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE); + +$DEBUG = 0; +@ISA = qw/GT::SQL::Driver::debug/; +$ERROR_MESSAGE = 'GT::SQL'; + +# Get rid of a 'used only once' warnings +$DBI::errstr if 0; + +sub new { +# -------------------------------------------------------- +# Create a new driver sth. +# + my $this = shift; + my $class = ref $this || $this; + my $opts = {}; + my $self = bless {}, $class; + + if (@_ == 1 and ref $_[0]) { $opts = shift } + elsif (@_ and @_ % 2 == 0) { $opts = {@_} } + else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") } + + $self->{_debug} = $opts->{_debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL'; + + # Drivers can set this to handle name case changing for fetchrow_hashref + $self->{hints} = $opts->{hints} || {}; + + for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) { + $self->{$_} = $opts->{$_} if exists $opts->{$_}; + } + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; +} + +$COMPILE{execute} = __LINE__ . <<'END_OF_SUB'; +sub execute { +# -------------------------------------------------------- +# Execute the query. +# + my $self = shift; + my $do = $self->{do}; + my $rc; + +# Debugging, stack trace is printed if debug >= 2. + 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/
        /\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 (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) { + $meth = "_execute_$meth"; + $rc = $self->$meth(@_) or return; + } + else { + $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); + } + + if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) { + my $elapsed = Time::HiRes::time() - $time; + $self->debug(sprintf("Query execution took: %.6fs", $elapsed)); + } + + $rc; +} +END_OF_SUB + +# Define one generic execute, and alias all the specific _execute_* functions to it +sub _generic_execute { + my $self = shift; + $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr); +} +for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) { + $_ = \&_generic_execute; +} + +sub rows { + my $self = shift; + return $self->{_rows} if exists $self->{_rows}; + return $self->{rows} if exists $self->{rows}; + $self->{sth}->rows; +} + +sub fetchrow_arrayref { +# ----------------------------------------------------------------------------- + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_arrayref; + return shift @{$self->{_results}}; +} + +sub fetchrow_array { +# ----------------------------------------------------------------------------- +# When called in scalar context, returns either the first or last row, as per +# DBI, so avoid using in scalar context when fetching more than one row. +# + my $self = shift; + $self->{_results} or return $self->{sth}->fetchrow_array; + my $arr = shift @{$self->{_results}}; + return $arr ? wantarray ? @$arr : $arr->[0] : (); +} + +# ----------------------------------------------------------------------------- +# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's +# documentation no longer mentions it at all). +*fetchrow = \&fetchrow_array; *fetchrow if 0; + +sub fetchrow_hashref { +# ----------------------------------------------------------------------------- + my $self = shift; + return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results}; + $self->{sth}->fetchrow_hashref; +} + +$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB'; +sub _fetchrow_hashref { +# ----------------------------------------------------------------------------- +# Handles row fetching for driver that can't use the default ->fetchrow_hashref +# due to needing column case mapping ($sth->{hints}->{case_map}), or special +# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit +# handling). +# + my $self = shift; + + my %case_map; # returnedname => ReturnedName, but only for columns that use upper case + if ($self->{hints}->{case_map}) { + if (exists $self->{schema}->{cols}) { + my $cols = $self->{schema}->{cols}; + %case_map = map { lc $_ => $_ } keys %$cols; + } + else { + for my $table (keys %{$self->{schema}}) { + for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) { + $case_map{lc $col} = $col; + } + } + } + } + + if ($self->{_results}) { + my $arr = shift @{$self->{_results}} or return; + + my $i; + my %selected = map { lc $_ => $i++ } @{$self->{_names}}; + my %hash; + + for my $lc_col (keys %selected) { + if (exists $case_map{$lc_col}) { + $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}]; + } + else { + $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}]; + } + } + return \%hash; + } + else { + my $h = $self->{sth}->fetchrow_hashref or return; + for (keys %$h) { + $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_}; + } + return $h; + } +} +END_OF_SUB + +sub fetchall_arrayref { +# --------------------------------------------------------------- + my $self = shift; + return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results}; + + my $opt = shift; + if ($opt and ref $opt eq 'HASH') { + my @ret; + while (my $row = $self->fetchrow_hashref) { + for (keys %$row) { + delete $row->{$_} unless exists $opt->{$_}; + } + push @ret, $row; + } + return \@ret; + } + + my $results = $self->{_results}; + $self->{_results} = []; + return $results; +} + +sub fetchall_list { map @$_, @{shift->fetchall_arrayref} } + +sub fetchall_hashref { +# ----------------------------------------------------------------------------- +# This is very different from DBI's fetchall_hashref - this is actually +# equivelant to DBI's ->fetchall_arrayref({}) +# + my $self = shift; + my @results; + while (my $hash = $self->fetchrow_hashref) { + push @results, $hash; + } + return \@results; +} + +sub row_names { + my $self = shift; + $self->{_names} || $self->{sth}->{NAME}; +} + +$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB'; +sub insert_id { +# ------------------------------------------------------------------- +# Returns the value of the last record inserted. +# + return $_[0]->{sth}->{insertid}; +} +END_OF_SUB + +sub DESTROY { +# ------------------------------------------------------------------- +# Calls finish on the row when it is destroyed. +# + my $self = shift; + $self->debug("OBJECT DESTROYED") if $self->{_debug} > 2; + $self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish"); +} + +sub _AUTOLOAD { +# ------------------------------------------------------------------- +# Autoloads any unknown methods to the DBI::st object. +# + my ($self, @param) = @_; + my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/; + + if (exists $DBI::st::{$attrib}) { + local *code = $DBI::st::{$attrib}; + if (*code{CODE}) { + $self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1; + return code($self->{sth}, @param); + } + } + + $GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD; + goto >::SQL::Driver::debug::AUTOLOAD; +} + +sub debug { +# ------------------------------------------------------------------- +# DBI::st has a debug that autoload is catching. +# + my $self = shift; + my $i = 1; + my ($package, $file, $line, $sub); + while (($package, $file, $line) = caller($i++)) { + last if index($package, 'GT::SQL') != 0; + } + while ($sub = (caller($i++))[3]) { + last if index($sub, 'GT::SQL') != 0; + } + my $msg = $_[0]; + $msg .= " from $sub" if $sub; + $msg .= " at $file" if $file; + $msg .= " line $line" if $line; + $msg .= "\n"; + return $self->SUPER::debug($msg); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Editor.pm new file mode 100644 index 0000000..b5aabc9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Editor.pm @@ -0,0 +1,1082 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Base +# CVS Info : 087,071,086,086,085 +# $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Editor; +# ================================================================== +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERRORS $error $ERROR_MESSAGE/; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; + +$VERSION = sprintf "%d.%03d", q$Revision: 1.79 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; +@ISA = qw(GT::SQL::Base); +$DEBUG = 0; + +sub new { + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + +# Get the arguments + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)"); + + ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). 'table' must be specified in the hash. It needs to be the an object from GT::SQL::Table."); + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{table} = $opts->{table}; + $self->{connect} = $opts->{connect}; + +# We almost always need to be connected. + $self->{table}->connect or return; + return $self; +} + + +################################################################# +##### Editing functions ##### +################################################################# +## +# $obj->add_col($col_name, +# { +# size => 20, +# type => 'int', +# view_size => 20, +# form_display => "my col", +# regex => 'myregex' +# } +# ); +# ------------------------------------ +# +## +$COMPILE{add_col} = __LINE__ . <<'END_OF_SUB'; +sub add_col { + my ($self, $name, $col) = @_; + + $name and ref $col eq 'HASH' or return $self->fatal(BADARGS => '$obj->add_col(COLUMN_NAME, HASH_REF)'); + my $c = $self->{table}->cols; + + # Check the database instead of the def file so that we don't end up with + # an inability to add a column when the database and def files are out of + # sync. + my $exists = $self->{table}->{driver}->column_exists($self->{table}->name, $name); + $exists and return $self->warn(COLEXISTS => $name); + +# You are not permitted to add a not_null column without a default to a table - +# the default is required for existing columns. You could, if you really want +# it with no default, create it with a default, then alter it to drop the +# default. + return $self->warn(NOTNULLDEFAULT => $name) + if $col->{not_null} and (not defined $col->{default} or $col->{default} eq ''); + +# count file columns + my %fcols_initial = $self->{table}->_file_cols(); + +# handle the search indexes + my $tmp_weight = {}; + $tmp_weight = $self->_get_indexer()->pre_add_column($name, $col) or return if $col->{weight}; + +# get the column definition + my $col_props = $self->{table}->{driver}->column_sql($col); + my $table = $self->{table}->name; + +# Auto add a new position number. + $col->{pos} = keys(%$c) + 1; + +# Add the column into the table's column hash, for checking. +# N.B. - everything below this point _must_ reload the table information (i.e. +# via ->reset or ->reload) upon failure + $c->{$name} = $col; + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + + require GT::SQL::Creator; + GT::SQL::Creator::set_defaults($self, { $name => $col }); + +# Make the changes + $self->{table}->{driver}->add_column($table, $name, $col_props) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + +# Check for file columns + if (not keys %fcols_initial and uc $col->{form_type} eq 'FILE') { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->install({ parent_tablename => $self->{table}->name() }); + $self->{table}->_file_cols(1); + } + +# finish off the search indexes + if ($col->{weight}) { + $self->_get_indexer()->post_add_column($name, $col, $tmp_weight) or return; + } + + 1; +} +END_OF_SUB + +## +# $obj->drop_col($col_name); +# --------------------------- +# Drops the column specified by $col_name. +# If the column is referenced returns an error. +# If the column is itself an fk reference, the foreign key is dropped. +# +# $obj->drop_col($col_name, "remove"); +# ------------------------------------- +# Drops column and all fk references to it. +# +## +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { + my $self = shift; + my $name = shift || return $self->fatal(BADARGS => '$obj->drop_col(COLUMN_NAME,[ STRING ])'); + exists $self->{table}->cols->{$name} or return $self->warn(NOCOL => $name); + my $kill = shift; + + my %fcols = $self->{table}->_file_cols(); + my $table = $self->{table}->name; + if ($self->_is_referenced($table, $name)) { + if (defined $kill) { + $self->_remove_references($table, $name); + } + else { + return $self->warn(REFCOL => $name, $table); + } + } + + my @fk_tables = grep exists $self->{table}->{fk}->{$_}->{$name}, keys %{$self->{table}->{fk}}; + if (@fk_tables) { + $self->drop_fk($_, 1); + } + + my $tmp_weight = {}; + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->_get_indexer()->pre_delete_column($name, $self->{table}->cols->{$name}) or return + } + +# Columns + my $old_col = delete $self->{table}->cols->{$name}; + +# Primary key + $self->{table}->pk(grep $_ ne $name, $self->{table}->pk); + +# Foreign keys + while (my ($table, $fk) = each %{$self->{table}->fk}) { + for my $col (keys %$fk) { + if ($col eq $name) { + delete $self->{table}->fk->{$_}->{$col} + } + } + } + +# Indexes and uniques + for my $index (qw/index unique/) { + my $ndx = $self->{table}->$index(); + for (keys %$ndx) { + my @new = grep $_ ne $name, @{$ndx->{$_}}; + if (@new) { + $ndx->{$_} = \@new; + } + else { + delete $ndx->{$_}; + } + } + } + +# Update the positions. + my $cols = $self->{table}->cols; + my $i; + for my $col (sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols) { + $cols->{$col}->{pos} = ++$i; + } + +# Check for conflicts + $self->{table}->check_schema or return $self->{table}->reset; + +# File Handling + if ($fcols{$name}) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect}); + $ftable->debug_level($self->{_debug}); + $ftable->drop_col($name, $fcols{$name}->{file_save_scheme}) or return $self->{table}->reset; + $self->{table}->_file_cols(1); + } + +# Finish off the index table stuff + if (($self->{table}->cols->{$name} || {})->{weight}) { + $tmp_weight = $self->post_delete_column($name, $self->{table}->cols->{$name}, $tmp_weight) + or return $self->{table}->reset; + } + +# Make the changes - actually drop the column + $self->{table}->{driver}->drop_column($table, $name, $old_col) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + + 1; +} +END_OF_SUB + +## +# $obj->alter_col($column_name, \%new_defs); +# ------------------------------------------- +# +$COMPILE{alter_col} = __LINE__ . <<'END_OF_SUB'; +sub alter_col { + my ($self, $col, $defs) = @_; + + ref $defs eq 'HASH' or return $self->fatal(BADARGS => '$obj->alter_col(COLUMN_NAME, HASH_REF)'); + exists $self->{table}->{schema}->{cols}->{$col} or return $self->warn(NOCOL => $col); + + my %fcols = $self->{table}->_file_cols(); + +# Can't change the position, force it to what it was before. + my $orig = $self->{table}->{schema}->{cols}->{$col}; + my $table = $self->{table}->{name}; + +# Set the position, can't be changed. + $defs->{pos} = $orig->{pos}; + +# Check to see if we need to update the SQL. + my $orig_sql = $self->{table}->{driver}->column_sql($orig); + my $new_sql = $self->{table}->{driver}->column_sql($defs); + my $change = $orig_sql ne $new_sql; + +# If we've changed, check the keys. + if ($change) { + return $self->warn(REFCOL => $col, $table) if $self->_is_referenced($table, $col); + return $self->warn(COLREF => $col, $table) if exists $self->{table}->fk->{$col}; + } + +# Check for conflicts + my $old_col = $self->{table}->{schema}->{cols}->{$col}; + $self->{table}->{schema}->{cols}->{$col} = $defs; + $self->{table}->check_schema or return $self->{table}->reset; + +# adding a file column + if (not keys %fcols and $defs->{form_type} and lc $defs->{form_type} eq 'file') { + + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->debug_level($self->{_debug}); + $ftable->install({parent_tablename => $self->{table}->name() }); + } + +# removing a file column + elsif ($fcols{$col} and not ($defs->{form_type} and lc $defs->{form_type} eq 'file')) { + require GT::SQL::File; + my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} }); + $ftable->drop_col($col); + } + +# Make the changes + if ($change) { + $self->{table}->{driver}->alter_column($table, $col, $new_sql, $old_col) or return $self->{table}->reset; + } + $self->{mods}->{$table} = $self->{table}; + $self->save_state or return; + +# finish off the file column setup + if ($defs->{form_type} and lc $defs->{form_type} eq 'file') { + $self->{table}->update({ $col => '' }); + $self->{table}->_file_cols(1); + } + + 1; +} +END_OF_SUB + +## +# $obj->add_index($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_index} = __LINE__ . <<'END_OF_SUB'; +sub add_index { + my ($self, $index_name, $columns) = @_; + ref $columns eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_index(INDEX_NAME => ARRAY_REF)'); + +# Do the columns exist? + for (@$columns) { + return $self->warn(NOCOL => $_) unless exists $self->{table}->cols->{$_}; + } + + exists $self->{table}->{schema}->{index}->{$index_name} + and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + $self->{table}->{schema}->{index}->{$index_name} = $columns; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_index($table, $index_name, @$columns) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_index($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB'; +sub drop_index { + my ($self, $index_name) = @_; + $index_name or return $self->fatal(BADARGS => '$obj->drop_index(INDEX_NAME)'); + exists $self->{table}->index->{$index_name} or return $self->warn(NOINDEX => $index_name); + +# Check for conflicts + delete $self->{table}->index->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_unique($index_name => [ field1, field2 .. ]); +# -------------------- +# Add a unique index to the table specified by +# $index_name. The array should contain fields +# that will be part of the index. +## +$COMPILE{add_unique} = __LINE__ . <<'END_OF_SUB'; +sub add_unique { + my ($self, $index_name, $indexes) = @_; + + $index_name and ref $indexes eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_unique(INDEX_NAME => ARRAY_REF)'); +# Do the columns exist? + for (@$indexes) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + exists $self->{table}->unique->{$index_name} and return $self->warn(INDXEXISTS => $index_name); + + my $table = $self->{table}->name; + +# Do the new fields have unique data in them? + my $in = join ", " => @{$indexes}; + my $query = "SELECT $in, COUNT(*) AS hits FROM $table GROUP BY $in HAVING "; + $query .= lc $self->{table}->{connect}->{driver} eq 'mysql' ? 'hits' : 'COUNT(*)'; + $query .= ' > 1'; + $self->debug($query) if $self->{_debug}; + + my $sth = $self->{table}->do($query) or return; + $sth->fetchrow and return $self->warn(NOTUNIQUE => $index_name); + +# Check for conflicts + $self->{table}->unique->{$index_name} = $indexes; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_unique($table, $index_name, @$indexes) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_unique($index_name); +# -------------------------------- +# Drops an index by the name $index_name. +## +$COMPILE{drop_unique} = __LINE__ . <<'END_OF_SUB'; +sub drop_unique { + my ($self, $index_name) = @_; + + $index_name or return $self->fatal(BADARGS => '$obj->drop_unique(INDEX_NAME)'); + exists $self->{table}->unique->{$index_name} or return $self->warn(NOUNIQUE => $index_name); + + my $table = $self->{table}->name; + +# Check for conflicts + delete $self->{table}->unique->{$index_name}; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_pk($field1, $field2, ...); +# ------------------------------------- +# Addes primary keys specified by list. If there is already a primary key it +# drops it and adds all the keys at the same time. If there is no primary +# keys this makes sure the data in the primary keys is unique. +## +$COMPILE{add_pk} = __LINE__ . <<'END_OF_SUB'; +sub add_pk { + my ($self, @fields) = @_; + + @fields or return $self->fatal(BADARGS => '$obj->add_pk(COLUMN1, COLUMN2, ...)'); + for (@fields) { + exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_); + } + + my ($table, %add) = $self->{table}->name; + if ($self->{table}->pk) { + $self->{table}->{driver}->drop_pk($table) or return; + %add = map { $_ => 1 } @{delete $self->{table}->{schema}->{pk}}; + } + +# Check for conflicts + for (@fields) { $add{$_} = 1 } + $self->{table}->{schema}->{pk} = [keys %add]; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + $self->{table}->{driver}->create_pk($table, keys %add) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->drop_pk; +# -------------- +# Drops the current primary key. +## +$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB'; +sub drop_pk { + my $self = shift; + $self->{table}->pk or return $self->warn('NOPK'); + +# Check for conflicts + $self->{table}->{schema}->{pk} = []; + $self->{table}->check_schema or return $self->{table}->reset; + +# Make the changes + my $table = $self->{table}->name; + $self->{table}->{driver}->drop_pk($table) or return $self->{table}->reset; + $self->{mods}->{$table} = $self->{table}; + $self->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_fk( RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +## +$COMPILE{add_fk} = __LINE__ . <<'END_OF_SUB'; +sub add_fk { + my $self = shift; + $self->{table}->fk(@_) or return; + 1; +} +END_OF_SUB + +## +# $obj->drop_fk(RELATION_NAME [, SKIPSAVE]); +# --------------------------------------------- +# Drops the foreign key relation for a given relation. If a second parameter +# is passed, and true, the state of the current table will not be saved (any +# other changed tables are, however). +## +$COMPILE{drop_fk} = __LINE__ . <<'END_OF_SUB'; +sub drop_fk { + my ($self, $tbl, $nosave) = @_; + my $table = $self->{connect}->{PREFIX} . $tbl; + delete $self->{table}->{schema}->{fk}->{$table} + or return $self->warn(FKNOEXISTS => $tbl, $self->{table}->{name}); + my $remote = $self->new_table($table); + my $rfk = $remote->fk_tables || []; + $remote->fk_tables([grep $_ ne $self->{table}->{name}, @$rfk]); + $remote->save_state; + $self->{table}->save_state unless $nosave; +} +END_OF_SUB + +## +# $obj->add_tree(ARGS); +# --------------------- +# Create a tree table for the current table. +# 'ARGS' is a hash or hash reference consisting of the following: +# father => 'father_id_column', +# root => 'root_id_column', +# depth => 'depth_column' +# where 'father_id_column', 'root_id_column', and 'depth_column' are the names +# of the columns you will use for keeping track of the father record, root +# record, and the depth from the root record, respectively. All of these +# columns should already exist - an error will occur if they do not. +# +# Any other arguments passed in will be passed straight through to +# GT::SQL::Tree->create +## +$COMPILE{add_tree} = __LINE__ . <<'END_OF_SUB'; +sub add_tree { + my $self = shift; + + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(HASH or HASH REF)'); + + return $self->warn(TREEEXISTS => $self->{table}->{name}) if $self->{table}->{schema}->{tree} and ($input->{force} || 'force') eq 'check'; + + $input->{father} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., father => \'father_col\', ...)'); + $input->{root} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., depth => \'depth_col\', ...)'); + + require GT::SQL::Tree; + GT::SQL::Tree->create(debug => $self->{_debug}, %$input, table => $self->{table}); +} +END_OF_SUB + +$COMPILE{drop_tree} = __LINE__ . <<'END_OF_SUB'; +sub drop_tree { + my $self = shift; + my $tree = $self->{table}->tree or return; + $tree->destroy; +} +END_OF_SUB + +$COMPILE{load_data} = __LINE__ . <<'END_OF_SUB'; +sub load_data { +# --------------------------------------------------------------- +# imports the contents of a file with validation. +# + my ($self, $file, $options) = @_; + -f $file and -r _ or return $self->fatal(FILENOEXISTS => $file); + $self->{table}->connect or return; + + my $delim = $options->{delim} || '|'; + my @cols = ref $options->{cols} ? @{$options->{cols}} : @{$self->{table}->ordered_columns}; + + local *FILE; + open FILE, $file or return $self->warn(CANTOPEN => $file, "$!"); + while () { + chomp; + my $i = 0; + my %fields = map { $cols[$i++] => $_ } split /(?{table}->insert(\%fields, 1) or print "Line $. skipped - validation failed:\n$GT::SQL::error\n\n"; + } + close FILE; + 1; +} +END_OF_SUB + +$COMPILE{export_data} = __LINE__ . <<'END_OF_SUB'; +sub export_data { +# --------------------------------------------------------------- +# Dumps the contents of a table to a file. +# + my $self = shift; + my $opt = shift; + ref $opt eq 'HASH' or return $self->fatal(BADARGS => '$obj->export_data(HASHREF)'); + + my $order = $opt->{order}; + my $delim = $opt->{delim} || '|'; + my $file = $opt->{file} || undef; + my $header = $opt->{header} || undef; + my $table = $self->{table}->name; + + my @order = $order + ? ref $order eq 'ARRAY' ? @$order : $order + : $self->{table}->ordered_columns; + + my ($offset, $limit) = (0, 1000); + + local *FILE; + if ($file) { + open FILE, "> $file" or return $self->warn(CANTOPEN => $file, "$!"); + } + while () { + $self->{table}->select_options("LIMIT $limit OFFSET " . ($offset++ * $limit)); + my $sth = $self->{table}->select(\@order); + + if ($header) { + print FILE join($delim, @order), "\n"; + $header = undef; + } + my $count = 0; + while (my $arr = $sth->fetchrow_arrayref) { + ++$count; + for (@$arr) { + y/\r//d; + s/\Q$delim\E/``/g; + s/\n/~~/g; + } + my $joined = join $delim, @$arr; + $file + ? print FILE $joined, "\n" + : print $joined, "\n"; + } + last unless $count; + } + 1; +} +END_OF_SUB + +## +# $obj->drop_search_driver +# ----------------- +# Drops current search driver +## +$COMPILE{drop_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub drop_search_driver { + my $self = shift; + + require GT::SQL::Search; + if ($self->{table}->search_driver) { + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}) or return; + $indexer->drop_search_driver or return; + } + $self->{table}->search_driver('NONINDEXED'); + $self->{table}->save_state; + 1; +} +END_OF_SUB + +## +# $obj->add_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{add_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub add_search_driver { + my $self = shift; + my $olddriver = $self->{table}->search_driver(); + my $newdriver = shift or return; + + require GT::SQL::Search; + +# check and see if driver is ok + GT::SQL::Search->driver_ok($newdriver, { table => $self->{table} }) or return; + +# load the driver + my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}, driver => $newdriver) or return; + $indexer->add_search_driver or return; + + $self->{table}->search_driver($newdriver); + $self->{table}->save_state or return; + 1; +} +END_OF_SUB + +## +# $obj->change_search_driver +# ----------------- +# Adds new search driver +## +$COMPILE{change_search_driver} = __LINE__ . <<'END_OF_SUB'; +sub change_search_driver { + my $self = shift; + my $newdriver = uc shift or return; + my $driver = $self->{table}->search_driver; + $driver eq $newdriver and return $self->warn(SAMEDRIVER => $driver); + + $self->drop_search_driver() or return; + $self->add_search_driver($newdriver) or return; + + 1; +} +END_OF_SUB + +## +# $obj->drop_table; +# ----------------- +# Drops the current table. +## +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { + my $self = shift; + my $rm_fk = lc(shift or '') eq 'remove'; + my $table = $self->{table}->name; + my $tmp = $self->{table}->fk_tables() || []; + @$tmp and !$rm_fk and return $self->warn(TABLEREFD => $table); + + my $tmp_weights = {}; + if ($self->_uses_weights) { + $tmp_weights = $self->_get_indexer->pre_drop_table() or return + } + + $self->{table}->{driver}->drop_table($table) or return; + + delete $GT::SQL::OBJ_CACHE{"TABLE\0$table\0$self->{connect}->{def_path}"}; + +# If this table has a tree, drop it: + $self->drop_tree if $self->{table}->{schema}->{tree}; + + unlink "$self->{connect}->{def_path}/$table.def"; + + for (keys %{$self->{table}->{schema}->{fk}}) { + next if $_ eq $table; + my $t = $self->new_table($_); + $t->{schema}->{fk_tables} = [grep $_ ne $table, @{$t->{schema}->{fk_tables}}]; + $t->save_state(); + } + + $self->_file_drop_tables(); + $self->_uses_weights and ($self->_get_indexer->post_drop_table($tmp_weights) or return); + $rm_fk and $self->_drop_related_fk_entries($table); + + 1; +} +END_OF_SUB + +$COMPILE{_file_drop_tables} = __LINE__ . <<'END_OF_SUB'; +sub _file_drop_tables { + my $self = shift; + if ( $self->{table}->_file_cols() ) { + require GT::SQL::File; + GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} })->drop_table(); + } +} +END_OF_SUB + +$COMPILE{_drop_related_fk_entries} = __LINE__ . <<'END_OF_SUB'; +sub _drop_related_fk_entries { + my $self = shift; + my $table_name = shift or return; + + my $fk = $self->{table}->fk() or return; + my $prefix = $self->{connect}->{PREFIX}; + for my $related_name ( keys %{$fk} ) { + my $table = $self->{table}->new_table($related_name); + my $fk_tables = $table->fk_tables() or next; + $fk_tables = [ grep { $_ ne $table_name } @{$fk_tables} ]; + $table->fk_tables( $fk_tables ); + $table->save_state(); + } + + 1; +} +END_OF_SUB + +########################################################################### +##### Private Functions ##### +########################################################################### + +$COMPILE{_is_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _is_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $fk = $self->new_table($table)->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + return 1; + } + } + } + } + 0; +} +END_OF_SUB + +$COMPILE{_remove_referenced} = __LINE__ . <<'END_OF_SUB'; +sub _remove_referenced { + my ($self, $mytable, $mycol) = @_; + for my $table (@{$self->{table}->fk_tables}) { + my $new_table = $self->{mods}->{$table} || $self->new_table($table); + my $fk = $new_table->fk; + if (exists $fk->{$mytable}) { + for my $key (keys %{$fk->{$mytable}}) { + if ($mycol eq $fk->{$mytable}->{$key}) { + delete $fk->{$mytable}->{$key}; + $self->{mods}->{$table} ||= $new_table; + } + if (not keys %{$fk->{$mytable}}) { + delete $fk->{$mytable}; + $self->{mods}->{$table} ||= $new_table; + } + } + } + } + 1; +} +END_OF_SUB + +$COMPILE{_remove_references} = __LINE__ . <<'END_OF_SUB'; +sub _remove_references { + my ($self, $mytable, $mycol) = @_; + for my $table (keys %{$self->{table}->fk}) { + if ($self->{table}->fk->{$table}->{$mycol}) { + delete $self->{table}->fk->{$table}->{$mycol}; + } + next if keys %{$self->{table}->fk->{$table}}; + my $t = $self->{mods}->{$table} || $self->new_table($table); + $t->{schema}->{fk_table} = [grep $_ ne $mytable, @{$t->fk_tables}]; + $self->{mods}->{$table} = $t; + } + 1; +} +END_OF_SUB + +sub save_state { + my $self = shift; + for my $table (keys %{$self->{mods}}) { + my $new_table = $self->{mods}->{$table}; + $new_table->save_state or return; + delete $self->{mods}->{$new_table}; + } + 1; +} + +sub _uses_weights { +#------------------------------------------------------------------------------- + return keys %{$_[0]->{table}->weight()} +} + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self->{table}, + debug => $self->{_debug} + ); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Editor - an interface to modify an SQL table. + +=head1 SYNOPSIS + + my $editor = $DB->editor('Table'); + $editor->add_col(Foo => { size => 20, type => 'int' }); + $editor->export_data('/tmp/foo.txt'); + +=head1 DESCRIPTION + +GT::SQL::Editor is an easy way to do a lot of table maintenance +functions like: + +* Adding columns +* Dropping columns +* Changing columns +* Altering keys +* Importing data +* Dropping data + +To get an editor object, you simply call C from a +GT::SQL object, and specify the tablename you want to edit: + + $editor = $db->editor('TableName'); + +Note: You can not use Editor with relations, only tables. + +=head2 add_col + +This method allows you to add a column to the current table. +All attributes for the column are passed in a single hash. + + $editor->add_col($col_name, + { + size => 20, + type => 'int', + view_size => 20, + form_display => "my col", + regex => 'myregex' + } + ); + +The same rules apply to this method that apply when you +define a column for creating a table. You must specify the +type. + +=head2 drop_col + +This method drops a column from the current table. Checks +are made to ensure the column is not linked to by a foreign +key relation. + + $editor->drop_col($col_name); + +-or- + + $editor->drop_col($col_name, "remove"); + +If you just specify the column name C will check if +the column is referenced in a foreign key relation. If it +is C will return undef and set the error message in +$GT::SQL::error. If it is not the column will be dropped. + +If you specify "remove" C will remove all foreign +key relations that point to the specified column. + +If the specified column is itself a foreign key relation, the relation will be +dropped. + +=head2 alter_col + +This allows you to make changes to a columns type, null status, +etc.. + + $editor->alter_col($column_name, + { + size => 20, + type => 'int' + }); + +The first argument is the column name the second is the definitions. +The column definitions are exactly the same as the column +definitions from the create. The type must be specified. + +You can not add attributes to the column in this way. +You must specify the original definitions along with the +changes you need to make. + +=head2 add_unique + +This allows you to add a unique index to the current table. +If the name of the unique index is the same as another +index you C will return undef and set the error +in $GT::SQL::error. + + $editor->add_unique($index_name => [ $field1, $field2 .. ]); + +The name of the new index is the first argument. The second argument +is an array reference containing the columns that will be indexed. +The order of the columns are maintained for the unique index. +If you specify an index that has data in it that is not unique +(yes we do a select on the database) C will return +an error and set the error in $GT::SQL::error. + +=head2 drop_unique + +This method allows you to drop a unique index for the current +table. If the unique index does not exist C will +return undef and set the error in $GT::SQL::error. C +will also check to make sure dropping the unique index will not +cause problems for the database structure. If dropping the unique +index will cause a problem C will return undef and set +the error in $GT::SQL::error. + + $editor->drop_unique($index_name); + +$index_name should be the name of the unique index to drop. + +=head2 add_index + +This takes the same arguments as C and return the same thing. +The only difference is C has no reason to check the content of +the current table because indexes are not unique. unique indexes are :) + + $editor->add_index($index_name => [ $field1, $field2 .. ]); + +=head2 drop_index + +This method drops the specified index from the current table. +C will check to make sure no problems are caused from +dropping the index. If there are C will return undef +and set the error in $GT::SQL::error. + + $editor->drop_index($index_name); + +$index_name should be the name of the index to drop. + +=head2 add_pk + +This method allows you to add a primary key to the current +database. + + $editor->add_pk($field1, $field2, ...); + +If there is already a primary key in the database C +will drop the key and add the this new one. The table +will be check to make sure this change does not create problems +for the table. I problem is auto increment not being the primary +key anymore. If there is a problem this function returns undef +and stores the error in $GT::SQL::error. + +=head2 drop_pk + +This method drops the current primary key. If there is no primary +key to drop it returns undef and sets the error in $GT::SQL::error. + + $editor->drop_pk; + +If dropping the primary key will cause problems for the database +this method will return undef and set the error in $GT::SQL::error. + +=head2 add_fk + +This method allows you to add foreign key relations to the current +table. + + $editor->add_fk($RELATION_NAME, { $SOURCE_FIELD_1 => $TARGET_FIELD }); + +You can not link your foreign key to tables that do not exist. Also the +columns types and lengths for the two columns must be the same. +Circularity is not allowed either. That is a set of foreign keys can not +end up pointing back at the same table they started at. All of these things +are checked when this is added. If anything does not match this method returns +undef and sets the error in $GT::SQL::error. + +=head2 drop_fk + +This method drops the specified foreign key relation. + + $editor->drop_fk($table); + +$table should be the name of the foreign table the foreign +key points to. + +=head2 drop_table + +This method drops the current table. If there are any foreign keys +pointing to this table this method will fail and return undef. The error +will be set in $GT::SQL::error. + + $editor->drop_table; + +-or- + + $editor->drop_table("remove"); + +If the first argument to this method is remove it will remove all +the foreign key relations that point to this table. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm new file mode 100644 index 0000000..ebf9e9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm @@ -0,0 +1,1132 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::File +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# + +package GT::SQL::File; + +use strict; +use GT::SQL; +use GT::SQL::Base; +use GT::AutoLoader; +use GT::Base; +use vars qw/@ISA $ERRORS $ATTRIBS $LOG $ERROR_MESSAGE $PERMIT_REFS $DEBUG/; +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$ATTRIBS = { + db => undef, + connect => undef, + def_path => undef, + table_name => '', + table_object => undef, + parent_table => undef, + parent_table_name => undef, + file_save_in => '', + file_log_path => '', + file_name => '', + file_path => '', + file_fpath => '', + + File_Name => '', + ID => '', + ForeignColName => '', + ForeignColKey => '', + File_Name => '', + File_Directory => '', + File_MimeType => '', + File_Size => '', + File_RelativePath => '', + File_Binary => undef, + File_URL => '', + File_RelativeURL => '', + + file_handle => undef, +}; + +# this allows calls to the individual attribs through GT::SQL::File::Fh method +$PERMIT_REFS = { map { $_ => 1 } keys %$ATTRIBS }; +$LOG = { + ADDED => q~Added file %s to %s~, + REPLACE => q~Replaced file %s to %s~, + REMOVED => q~Deleted file %s~, + CREATEDDIR => q~Created directory %s~ +}; + +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + FILE_PARENTTBL => q~Cannot load parent table! (%s)~, + FILE_FILETBL => q~Cannot load file table! (%s)~, + FILE_NOGLOBREF => q~Need a file glob reference in (%s)~, + FILE_FILETOOBIG => q~File %s (%i bytes) exceeds maximum file size (%i bytes)~, + FILE_NOOPEN => q~Problems opening %s for writing: %s~, + FILE_NOBINMODE => q~Could not set %s to binmode: %s~, + FILE_NOCLOSE => q~Had problems closing file %s: %s~, + FILE_NOFILE => q~Could not find file related by ForeignColName => %s, ForeignColKey => %s: %s~, + FILE_FDELETE => q~Problems deleting file %s: %s~, + FILE_NOUNLINK => q~Could not unlink file %s: %s~, + FILE_PKREQ => q~Primary Key required~, + FILE_PKSINGLE => q~Composite Primary Keys not supported~, + FILE_DBDELETE => q~Problems deleting record: %s~, + FILE_DBDELETEALL => q~Problems deleting all records~, + FILE_DBSELECT => q~Problems selecting %s~, + FILE_NOREC => q~Could not find file record~, + FILE_DBDROP => q~Could not drop table %s: %s~, + FILE_DBEDITOR => q~Could not get editor object for table %s: %s~, + FILE_DBUPDATE => q~Problems updating record: %s~, + FILE_DBADD => q~Problems adding record: %s~, + FILE_ILLEGALCHAR => q~Illegal character found in %s~, + FILE_NOOPEN => q~Could not open %s because %s~, + FILE_NOWRITE => q~Could not write data into %s because %s~, + FILE_MKDIRFAIL => q~Couldn't create directory %s, because %s~, + FILE_UNKNOWNREF => q~Reference call '%s' does not refer to a method in GT::SQL::File or an allowed attribute.~, + FILE_NOTNULL => q~A file must be uploaded for the %s column~, + FILE_NULLDELETE => q~Cannot delete file, as a file is required for the %s column~, + FILE_NULLUPDATE => q~A file must be uploaded for the %s column~, +}; + +@$GT::SQL::ERRORS{keys %$ERRORS} = values %$ERRORS; + +use constant ENCODE => 1; + +$COMPILE{rescan} = __LINE__ . <<'END_OF_SUB'; +sub rescan { +#------------------------------------------------------------------------------- +# $obj->rescan(); +#---------- +# Rebuilds the database and attempts to ensure that database records are +# correct. This does not update the parent tables +# + my ($self) = @_; + + my %errs = (); + my %mods = (); + my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error); + my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error); + my %fcols = $ptbl->_file_cols(); + my $sth = $tbl->select() or return $self->error('FILE_DBSELECT', 'WARN', $GT::SQL::error); + while (my $href = $sth->fetchrow_hashref()) { + my $fpath = $self->_file_full_path($href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE); + +# does this file still exist? + if (! -e $fpath) { + $errs{$href->{ID}} = "NOFILE"; + $self->error('FILE_NOFILE', 'WARN', $href->{ForeignColName}, $href->{ForeignColKey}, "FILENOEXIST"); + $tbl->delete({ ForeignColName => $href->{ForeignColName}, ForeignColKey => "$href->{ForeignColKey}" }); + } + +# is it still the same file size? + elsif (-s _ != $href->{File_Size}) { + $mods{$href->{ID}} = "NEWSIZE"; + $href->{File_Size} = -s _; + $tbl->modify($href) or $errs{$href->{ID}} = "CANTMODIFY"; + } + } + + return \%errs, \%mods; +} +END_OF_SUB + +$COMPILE{log} = __LINE__ . <<'END_OF_SUB'; +sub log { +#------------------------------------------------------------------------------- +# $obj->log( $code, LIST ); +#---------- +# puts a log message into the logs file if the path has been set +# + my $self = shift; + my $code = shift; + my $logpath = $self->{file_log_path} or return; + + $self->_check_file_chars( $logpath ) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $logpath ); + CORE::open( LOG, ">>$logpath" ); + print LOG sprintf($LOG->{$code}, @_); + close( LOG ); +} +END_OF_SUB + +$COMPILE{add_file} = __LINE__ . <<'END_OF_SUB'; +sub add_file { +#------------------------------------------------------------------------------- +# $obj->addfile( $new_record, $new_record_id ) +#---------- +# puts a file away into the database +# + my ($self, $rec, $recid ) = @_; + return $self->replace_file( $rec, $recid ); +} +END_OF_SUB + +$COMPILE{replace_file} = __LINE__ . <<'END_OF_SUB'; +sub replace_file { +# -------------------------------------------------------------------------------------- +# $obj->replace_file( $new_record, $new_record_id ) +#---------- +# puts a file away into the database, if a file already exists in place, delete it +# + my ($self, $rec, $recid ) = @_; + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $fcols = { $ptable->_file_cols() }; + my $ftable = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + + foreach my $col_name ( keys %$fcols ) { + +# basic tests + my $col = $fcols->{$col_name}; + my $ref = ref $rec->{$col_name}; + my $fh = ( ( $ref and $ref !~ /SCALAR|ARRAY|HASH/ ) ? $rec->{$col_name} : $self->get_fh( $col_name, $rec ) ) or next; + $col->{file_max_size} and ( ( -s $fh ) <= $col->{file_max_size} or return $self->error( 'FILE_FILETOOBIG', 'WARN', "$fh", -s $fh, $col->{file_max_size} ) ); + +# now, delete the previous entry + if ( $ftable->count({ ForeignColName => $col_name, ForeignColKey => "$recid" }) ) { + ref $fh or $rec->{$col_name."_del"} and $self->delete_file( $col_name, $recid, $col->{file_save_scheme} ); + } + +# find out if we're simply going to skip the action here + not ref $fh and not $fh eq 'delete' and next; + +# get basic information setup + my @paths = split m.(/|\\)., "$fh"; #/\ + my $fname = $rec->{$col_name."_filename"} || pop @paths; + my $fdir = $col->{file_save_in}; + +# now that we have saved the information, add the record to the database + my $new_rec = $self->_file_getstats( $fname, $fdir, $col->{file_save_url}, -s $fh ); + + $new_rec->{ForeignColName} = $col_name; + $new_rec->{ForeignColKey} = $recid; + my $fid = $ftable->add($new_rec) or return $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ); + +# now try to save + my $fpath = $self->_file_full_path( $fname, $fdir, $fid, $col_name, $col->{file_save_scheme}, ENCODE ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + while (read($fh, my $buf, 512 * 1024)) { + print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ); + } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + + $self->log( 'ADDED', $fname, $fdir ); + + } + + return 1; +} +END_OF_SUB + +$COMPILE{delete_file} = __LINE__ . <<'END_OF_SUB'; +sub delete_file { +# -------------------------------------------------------------------------------------- +# $obj->delete_file( $col_name, $recid, $save_scheme ); +#---------- +# deletes the files and records associated +# function that is usually used internally +# + my ( $self, $col_name, $recid, $save_scheme ) = @_; + +# get the path to the file + my $tbl = $self->_tbl(); + my $rec = $tbl->get({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_NOFILE', 'WARN', $col_name, $recid, $GT::SQL::error ); + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col_name, + $save_scheme, + ENCODE + ); + +# nuke the database record + $tbl->delete({ ForeignColName => $col_name, ForeignColKey => "$recid" }) or return $self->error( 'FILE_FDELETE', 'WARN', $rec->{File_Name}, $GT::SQL::error); + +# nuke the file + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + $self->log( 'REMOVED', $rec->{File_Name} ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_records} = __LINE__ . <<'END_OF_SUB'; +sub delete_records { +# -------------------------------------------------------------------------------------- +# $obj->delete_records( $condition ) +#---------- +# deletes all records addressed by the condition. +# usually used in conjunction with a delete of the parent table elements. +# BUT must be called before parent table is deleted +# + my ($self, $where) = @_; + my $ptbl = $self->_parent_tbl() or return $self->error('FILE_PARENTTBL', 'WARN', $GT::SQL::error); + my @pk = $ptbl->pk() or return $self->error('FILE_PKREQ', 'WARN'); + @pk == 1 or return $self->error('FILE_PKSINGLE', 'WARN'); + my $pk = $pk[0]; + my %fcols = $ptbl->_file_cols(); + my $sth = $ptbl->select([$pk], $where); + my $tbl = $self->_tbl() or return $self->error('FILE_FILETBL', 'WARN', $GT::SQL::error); + + while (my $raref = $sth->fetchrow_arrayref()) { + my $col_key = $raref->[0]; + my $fsth = $tbl->select([qw(ID ForeignColName File_Directory File_Name)], { ForeignColKey => "$col_key" }); + + while ( my $aref = $fsth->fetchrow_arrayref() ) { + my $fpath = $self->_file_full_path(map({$aref->[$_]} qw(3 2 0 1)), $fcols{$aref->[1]}->{file_save_scheme}, ENCODE) or next; + unlink $fpath or $self->error('FILE_NOUNLINK', 'WARN', $fpath, "$!"), next; + $self->log('REMOVED', $aref->[3]); + } + + $tbl->delete({ ForeignColKey => "$col_key" }) or $self->error('FILE_DBDELETE', 'WARN', $GT::SQL::error); + } +} +END_OF_SUB + +$COMPILE{update_records} = __LINE__ . <<'END_OF_SUB'; +sub update_records { +# -------------------------------------------------------------------------------------- +# $obj->update_records( $set, $condition ); +#---------- +# treated like $tbl->modify. will update all records with new files if required. +# if multiple records are to receive copies of the file, multiple copies of the files +# will be created on disk +# + my $self = shift; + my $set = shift or return $self->error ('BADARGS', 'FATAL', "First argument to update_records must be \$set of what was set."); + my $cond = shift or return $self->error ('BADARGS', 'FATAL', "Condition object must be passed as second argument."); + +# init variables + my $ptbl = $self->_parent_tbl(); + my @pk = $ptbl->pk() or return $self->error( 'FILE_PKREQ', 'WARN' ); + @pk == 1 or return $self->error( 'FILE_PKSINGLE', 'WARN' ); + my %fcols = $ptbl->_file_cols() or return $self->error ('BADARGS', 'FATAL', "update_records was called when there are no file columns, possibly corrupt def file."); + my %flocs = (); + +# find out which columns need to be updated + my @rcols = grep( defined ( $set->{$_} || $set->{$_."_del"} ), keys %fcols ) or return 1; # Nothing to do. + my $tbl = $self->_tbl(); + +# find out what records need to be updated + my $sth = $ptbl->select( [ $pk[0] ], $cond ); + while ( my $aref = $sth->fetchrow_arrayref() ) { + my $col_key = $aref->[0]; + +# now for each of the record's columns do what has to be done... delete, update, nothing? + foreach my $col ( @rcols ) { + + my $tmp = $flocs{$col} ||= {}; + my $fh = $tmp->{name} ? do { CORE::open SOURCE, "<$tmp->{path}"; \*SOURCE } : $self->get_fh( $col, $set ); + + ( not ref $fh and not $set->{$col."_del"} ) and ( $self->error( 'FILE_NOGLOBREF', 'WARN', $col ), next ); + + + my $fname = $tmp->{name} ||= ( $set->{$col."_filename"} || $self->get_filename( "$fh" ) ); + my $fdir = $tmp->{dir} ||= $fcols{$col}->{file_save_in}; + + my $rec; + if ( not $rec = $tbl->get({ ForeignColName => $col, ForeignColKey => "$col_key" }) ) { + $rec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + $rec->{ForeignColKey} = $col_key; + $rec->{ForeignColName} = $col; + $rec->{ID} = $tbl->add( $rec ) or $self->error( 'FILE_DBADD', 'WARN', $GT::SQL::error ),next; + } + else { + + my $fpath = $self->_file_full_path( + $rec->{File_Name}, + $rec->{File_Directory}, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + + if ( ref $fh ) { + my $trec = $self->_file_getstats( $fname, $fdir, $fcols{$col}->{file_save_url}, ( -s $fh ) ); + for ( keys %$trec ) { $rec->{$_} = $trec->{$_} }; + $tbl->modify($rec) or ( $self->error( 'FILE_DBUPDATE', 'WARN', $GT::SQL::error ),next ); + } + elsif ( $set->{$col."_del"} ) { + $tbl->delete({ ForeignColName => $col, ForeignColKey => "$col_key" }) or $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + next; + }; + + } + + my $fpath = $tmp->{path} ||= $self->_file_full_path( + ( $rec->{File_Name} = $tmp->{name} ), + $fdir, + $rec->{ID}, + $col, + $fcols{$col}->{file_save_scheme}, + ENCODE + ); + + $self->_check_file_chars($fpath) or return $self->error( 'FILE_ILLEGALCHAR', 'WARN', $fpath ); + CORE::open( F, ">$fpath" ) or return $self->error( 'FILE_NOOPEN', 'WARN', $fpath, "$!" ); + binmode $fh or return $self->error( 'FILE_NOBINMODE', 'WARN', 'input file', "$!" ); + binmode(F) or return $self->error( 'FILE_NOBINMODE', 'WARN', 'output file', "$!" ); + while (read($fh, my $buf, 512 * 1024)) { + print F $buf or return $self->error( 'FILE_NOWRITE', 'WARN', $fpath, "$!" ); + } + close F or return $self->error( 'FILE_NOCLOSE', 'WARN', $fpath, "$!" ); + close $fh; + + $self->log( 'ADDED', $rec->{File_Name}, $fdir ); + } + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_record} = __LINE__ . <<'END_OF_SUB'; +sub _delete_record { +# -------------------------------------------------------------------------------------- +# $obj->_delete_record( $columnname, $columnkey, $save_scheme ); +#---------- +# takes the parameters that identify a record in the _File uniquely and deletes +# record and file +# + my $self = shift; + my $col_name = shift or return; + my $col_key = shift or return; + my $save_scheme = shift or return;; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + +# get the column information + my $href = $tbl->get({ + ForeignColName => $col_name, + ForeignColKey => "$col_key", + }) or return $self->error( 'FILE_NOREC', 'WARN', $GT::SQL::error ); + + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols() or return; + +# get the filename of the record + my $fname = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $col_key, $col_name, $save_scheme, ENCODE); + +# delete the file now that we have the file path + unlink $fname or return $self->error( 'FILE_NOUNLINK', 'WARN', $fname, "$!" ); + +# nuke the record + $tbl->delete({ + ForeignColName => $col_name, + ForeignColKey => "$col_key", + }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# -------------------------------------------------------------------------------------- +# $obj->delete_call( $col_name ) +#---------- +# takes the name of a file column from the parent and deletes all files and records +# associated +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my $ptbl = $self->_parent_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptbl->_file_cols(); + + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $fcols{$href->{ForeignColName}}->{file_save_scheme}, ENCODE); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete_all() or return $self->error( 'FILE_DBDELETEALL', 'WARN', $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB'; +sub drop_col { +# -------------------------------------------------------------------------------------- +# $obj->drop_col( $name ) +# ----- +# $name : name of column to drop +# ----- +# Will remove all files associated to that particular column. If there are no more +# file columns, as it is no longer required, drop the file table . +# + my $self = shift; + my $name = shift; + + my $tbl = $self->_tbl() or return 1; + my $ptbl = $self->_parent_tbl(); + my %fcols = $ptbl->_file_cols(); + my $save_scheme = shift || $fcols{$name}->{file_save_scheme}; + my $sth = $tbl->select({ ForeignColName => $name }) or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $name, $save_scheme, ENCODE); + unlink $fpath or $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + $tbl->delete({ ForeignColName => $name }) or return $self->error( 'FILE_DBDELETE', 'WARN', $GT::SQL::error ); + + delete $fcols{$name}; + +# if there are no file based columns left, we can drop the file support table + require GT::SQL::Editor; + if ( not %fcols ) { + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table('remove') or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + } + + return 1; +} +END_OF_SUB + +$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB'; +sub drop_table { +# -------------------------------------------------------------------------------------- +# $obj->drop_table(); +#---------- +# deletes all files in the table and drops the table (including records) +# + my $self = shift; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $self->_parent_tbl()->_file_cols() or return; + my $sth = $tbl->select() or return $self->error( 'FILE_DBSELECT', 'WARN', $GT::SQL::error ); + + while ( my $href = $sth->fetchrow_hashref() ) { + my $save_scheme = $fcols{$href->{ForeignColName}}->{file_save_scheme}; + my $fpath = $self->_file_full_path( $href->{File_Name}, $href->{File_Directory}, $href->{ID}, $href->{ForeignColName}, $save_scheme, ENCODE); + unlink $fpath or return $self->error( 'FILE_NOUNLINK', 'WARN', $fpath, "$!" ); + } + + require GT::SQL::Editor; + my $e = GT::SQL::Editor->new( debug => $self->{_debug}, table => $tbl, connect => $self->{connect}) or return $self->error( 'FILE_DBEDITOR', 'WARN', $tbl->name(), $GT::SQL::error ); + $e->drop_table() or return $self->error( 'FILE_DBDROP', 'WARN', $tbl->name(), $GT::SQL::error ); + + return 1; +} +END_OF_SUB + +$COMPILE{open} = __LINE__ . <<'END_OF_SUB'; +sub open { +# -------------------------------------------------------------------------------------- +# $obj->open( $path_to_file ); +#---------- +# creates a GT::SQL::File::Fh Filehandle object +# + my $self = shift; + return GT::SQL::File::Fh->new(@_); +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# -------------------------------------------------------------------------------------- +# $obj->file_info( $columnname, $primarykeyvalue ); +#---------- +# returns a filehandle to file stored in database. if there is none, returns +# undef with an error set in $GT::SQL::error +# + my $self = shift; + my $name = shift or return; + my $key = shift or return; + + my $tbl = $self->_tbl() or return $self->error( 'FILE_PARENTTBL', 'WARN', $GT::SQL::error ); + my $ptable = $self->_parent_tbl() or return $self->error( 'FILE_FILETBL', 'WARN', $GT::SQL::error ); + my %fcols = $ptable->_file_cols(); + my $file_rec = $tbl->get({ ForeignColName => $name , ForeignColKey => $key }) or return $self->error( 'FILE_NOFILE', 'WARN', $name, $key, $GT::SQL::error ); + + my $relpath = $self->_file_full_path( + $file_rec->{File_Name}, + '', + $file_rec->{ID}, + $name, + $fcols{$name}->{file_save_scheme}, + ENCODE + ); + my $fpath = $file_rec->{File_Directory} . $relpath; + $file_rec->{File_RelativePath} = $relpath; + +# Files written to disk are escaped. They need to be escaped again for URLs. + require GT::CGI; + (my $relurl = $relpath) =~ s{([\\/])([^\\/]+)$}{$1 . GT::CGI->escape($2)}e; + $file_rec->{File_RelativeURL} = $relurl; + $file_rec->{File_URL} = $file_rec->{File_URL} . $relurl; + + return GT::SQL::File::Fh->new( $fpath, $file_rec ); +} +END_OF_SUB + +$COMPILE{_file_full_path} = __LINE__ . <<'END_OF_SUB'; +sub _file_full_path { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_full_path( $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) +#---------- +# $fname : filename +# $fdir : directory of file +# $fid : id of the parent record +# $save_scheme : hashed or simple +# $enc : if we should encode the filepath or try to decode it +#---------- +# returns the full path to the storeage location and name of the file the record +# points at +# the filename is typically encoded for the sake of special characters +# + my ( $self, $fname, $fdir, $fid, $fcol, $save_scheme, $enc ) = @_; + + $save_scheme ||= 'HASHED'; + +# build paths to which we'll save all the information + $fdir = $self->_filepath_munge( $fdir, $fid, $save_scheme ); + $fname = $self->_filename_munge( $fname, $fid, $fcol, $save_scheme, $enc ); + my $fpath = "$fdir/$fname"; + + return $fpath; +} +END_OF_SUB + +$COMPILE{_file_getstats} = __LINE__ . <<'END_OF_SUB'; +sub _file_getstats { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_file_getstats( $fname, $fpath, $fsize ); +#---------- +# starts to build a record to be used for inserts/modifies into +# the _File database table +# + my ( $self, $fname, $fpath, $furl, $fsize ) = @_; + require GT::MIMETypes; + my $rec = { + File_Name => $fname || '', + File_Directory => $fpath || '', + File_MimeType => GT::MIMETypes->guess_type($fname), + File_Size => defined $fsize ? $fsize : '', + File_URL => $furl || '' + }; + + return $rec; +} +END_OF_SUB + +$COMPILE{_filename_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filename_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filename_munge( $fname, $fid, $fcol, $method, $enc ) +#---------- +# should only be called internally. changes the filename so it can be saved without +# name conflicts +# + my ( $self, $fname, $fid, $fcol, $method, $enc ) = @_; + + if ($enc) { + $fname =~ s/([^\w.,-])/sprintf("%%%02X",ord($1))/ge; + } + else { + $fname =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge; + } + +# Most filesystems have a maximum filename length of 255 characters + if (length $fname > 255) { +# Keep the filename extension + my ($ext) = $fname =~ /(\.\w+)$/; + $ext ||= ''; + require GT::MD5; + $fname = GT::MD5::md5_hex($fname) . $ext; + } + + return "$fid-$fname"; +} +END_OF_SUB + +$COMPILE{_filepath_munge} = __LINE__ . <<'END_OF_SUB'; +sub _filepath_munge { +# -------------------------------------------------------------------------------------- +# GT::SQL::File->_filepath_munge(); +#---------- +# sets up the path directory where the file should be saved. +# + my ( $self, $fpath, $fid, $method ) = @_; + + if ( $method =~ /hashed/i ) { + my $fletter = ( reverse split //, $fid )[0]; + my $nfpath = "$fpath/$fletter"; + if ( $fpath ) { + -e $nfpath or mkdir $nfpath, 0777 or return warn "Couldn't make directory $nfpath because $!"; + } + $fpath = $nfpath; + } + + return $fpath; +} +END_OF_SUB + +$COMPILE{_check_file_chars} = __LINE__ . <<'END_OF_SUB'; +sub _check_file_chars { +#------------------------------------------------------------------------------- +# $obj->_check_file_chars( $fpath ); +#---------- +# return true if file path is ok +# + return $_[1] =~ /^[\w\/\\\-\.\:%]+$/; +} +END_OF_SUB + +$COMPILE{install} = __LINE__ . <<'END_OF_SUB'; +sub install { +#------------------------------------------------------------------------------- +# $obj->install( $options ); +#---------- +# creates the associate file parameter storage table +# $tops is passed into the creation option database +# + my ( $self, $opts ) = @_; + +# get the name of the table + my $ptbl_name = $opts->{parent_tablename} || $self->{parent_tablename}; + my $tb_name = $ptbl_name . '_Files'; + +# create the table + my $c = $self->creator( $tb_name ); + $c->cols({ + ID => { pos => 1, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + ForeignColName => { pos => 2, type => 'VARCHAR', size => 50 }, + ForeignColKey => { pos => 3, type => 'VARCHAR', size => 50 }, + File_Name => { pos => 4, type => 'VARCHAR', size => 255 }, + File_Directory => { pos => 5, type => 'VARCHAR', size => 255 }, + File_MimeType => { pos => 6, type => 'VARCHAR', size => 50 }, + File_Size => { pos => 7, type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + File_URL => { pos => 8, type => 'VARCHAR', size => 255 }, + +# under consideration.... +# File_Width => { pos => 8, type => 'INT', unsigned => 1, regex => '^\d+$' }, +# File_Height => { pos => 9, type => 'INT', unsigned => 1, regex => '^\d+$' }, + + }); + $c->pk('ID'); + $c->ai('ID'); + $c->index({ fk_lookup => [ 'ForeignColName', 'ForeignColKey' ] }); + $c->create( $opts->{action} || 'force' ) or return; + + return 1; + +} +END_OF_SUB + +$COMPILE{_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _tbl { +#------------------------------------------------------------------------------- +# $obj->_tbl( $options ) +#---------- +# returns GT::SQL::Table for _File table +# + my ( $self, $opts ) = @_; + + $self->{table_object} and return $self->{table_object}; + + my $tbl = eval { + $self->new_table( $opts->{table} || ( + ( + $opts->{parent_tablename} + || $self->{parent_tablename} + || ( ref $self->{parent_table} ? + do { + my $prefix = $self->{connect}->{PREFIX}; + my $name = $self->{parent_table}->name(); + $name =~ s,^$prefix,,; + $name; + } + : + '' + ) ) . '_Files' + ) ); + }; + + return $self->{table_object} = $tbl; +} +END_OF_SUB + +$COMPILE{_parent_tbl} = __LINE__ . <<'END_OF_SUB'; +sub _parent_tbl { +# ------------------------------------------------------------- +# $obj->_parent_tbl( $options ); +#---------- +# return the Table object for the parent table +# + my ( $self, $opts ) = @_; + $self->{parent_table} and return $self->{parent_table}; + return $self->_tbl( $self->{parent_table_name} || return ); +} +END_OF_SUB + +$COMPILE{File_Binary} = __LINE__ . <<'END_OF_SUB'; +sub File_Binary { +# ------------------------------------------------------------------- +# just returns true if the file is of binary type +# + my $self = shift; + defined $self->{File_Binary} and return $self->{File_Binary}; + $self->{file_fpath} and return $self->{File_Binary} = -B $self->{file_fpath}; + $self->{file_handle} and return $self->{File_Binary} = -B $self->{file_handle}; +} +END_OF_SUB + +$COMPILE{compare} = __LINE__ . <<'END_OF_SUB'; +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} +END_OF_SUB + +$COMPILE{get_filename} = __LINE__ . <<'END_OF_SUB'; +sub get_filename { +# ------------------------------------------------------------------- + my ($self, $fpath) = @_; + return +($fpath =~ /([^\\\/]+)$/)[0]; +} +END_OF_SUB + +$COMPILE{get_fh} = __LINE__ . <<'END_OF_SUB'; +sub get_fh { +# ------------------------------------------------------------------- + my ($self, $col, $values) = @_; + $values ||= {}; + + ref $values->{$col} and ref $values->{$col} ne 'SCALAR' and return $values->{$col}; + ref $values->{$col} eq 'SCALAR' and -f ${$values->{$col}} and -r _ and return GT::SQL::File->open(${$values->{$col}}); + return; +} +END_OF_SUB + +$COMPILE{pre_file_actions} = __LINE__ . <<'END_OF_SUB'; +sub pre_file_actions { +# ------------------------------------------------------------------- +# GT::SQL::File->pre_file_actions(); +#---------- +# Called before GT::SQL::Table::insert or GT::SQL::Table::update to setup all +# the columns and run tests to ensure the file is appropriate. Note that the +# $set hash will be modified (file columns are removed and/or modified and are +# returned). +# +# The $modify_ids (a single id or array ref of ids) argument is required for +# update()'s to verify that updates aren't made on rows that have file columns +# with not_null set and are currently empty. In addition to passing in to +# passing $modify_ids in, the GT::SQL::File object should also have the +# parent_table and connect options configured. For example, +# +# my $file = GT::SQL::File->new({ +# parent_table => $DB->table('Links'), +# connect => $DB->{connect} +# }); +# +# If $modify_ids is not passed in, then it is assumed the query will be an +# insert and all file columns with not_null set will be required. +# + my ($self, $fcols, $set, $opts, $modify_ids) = @_; + + $modify_ids = [$modify_ids] if ref $modify_ids ne 'ARRAY' and $modify_ids; + + my %fset; + for my $col (keys %$fcols) { +# insert() passes in through $opts, while modify passes them in through $set + my $delete = $opts->{"${col}_del"} || $set->{"${col}_del"}; + my $filename = $opts->{"${col}_filename"} || $set->{"${col}_filename"}; + my $fh = $set->{$col}; + +# Clean up the file columns (these will get set accordingly further down). +# This really doesn't have to be done since insert() and update() will only use +# valid columns, but we'll do it anyways. + delete $set->{"${col}_del"}; + delete $set->{"${col}_filename"}; + delete $set->{$col}; + +# A file has been uploaded, ignore requests to delete the file + if (ref $fh and -e $fh) { + $delete = undef; + } +# No or non-existent file passed in, make sure the file data isn't set + else { + $fh = undef; + $filename = undef; + } + +# Uploading a new file + if ($fh) { + my $max_size = $fcols->{$col}->{file_max_size} || 0; + return $self->warn('FILE_FILETOOBIG', $fh, -s $fh, $max_size) if $max_size and $max_size < -s $fh; + + $set->{$col} = $filename || $self->get_filename($fh); + $fset{$col} = $fh; + $fset{"${col}_filename"} = $filename if defined $filename and length $filename; + } +# Do our own not null checks here, so we can return a relevant error + elsif ($fcols->{$col}->{not_null}) { + +# You cannot delete a file from a not_null column during an update() - it must be replaced + if ($modify_ids and $delete) { + return $self->warn('FILE_NULLDELETE', $col); + } + elsif ($modify_ids) { +# The file column can be left blank on an update only if a file has already been uploaded + for (@$modify_ids) { + return $self->warn('FILE_NULLUPDATE', $col) unless $self->file_info($col, $_); + } + } +# This is an insert() - all not_null file columns should have a value set + else { + return $self->warn('FILE_NOTNULL', $col); + } + } + + if ($delete) { +# Deleting the file, so update the column in the parent table to '' + $set->{$col} = ''; + $fset{"${col}_del"} = $delete; + } + } + + return wantarray ? %fset : \%fset; +} +END_OF_SUB + +package GT::SQL::File::Fh; + +# =================================================================== +# Magic File Handle, lets you print the file name, but also act like +# a file handle for read, just like CGI.pm. +# +use strict qw/vars subs/; +no strict 'refs'; +use vars qw/$FH %FH_Conns $AUTOLOAD/; +use overload + '""' => \&as_string, + 'cmp' => \&compare, + 'fallback' => 1; +$FH = 1; +%FH_Conns = (); + +sub open { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + goto >::SQL::File::Fh::new; +} + +sub new { +# ------------------------------------------------------------------- +# Create a new filehandle based on a counter, and the filename. +# + my ( $pkg, $file, $opt ) = @_; + $file or return; + + my $fid = $FH++; + my $fname = sprintf( "FH%05d", $fid ); + my $fh = \do { local *{$fname}; *{$fname} }; + + CORE::open ($fh, $file || '') or return; + + bless $fh, $pkg; + + my $obj = GT::SQL::File->new({ + %{$opt||{}}, + file_name => GT::SQL::File->get_filename( $file ), + file_fpath => $file, + }) or return; + + $obj->File_Binary() and binmode $fh; + + $FH_Conns{$$fh} = $obj; + + return $fh; +} + +sub as_string { +# ------------------------------------------------------------------- +# Return the filename, strip off leading junk first. +# + my $self = shift; + return $FH_Conns{$$self}->{file_fpath}; +} + +sub compare { +# ------------------------------------------------------------------- +# Do comparisions, uses as_string to get file name first. +# + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} + + +sub AUTOLOAD { +# ------------------------------------------------------------------- + my $self = shift; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + + my $fh_ref = $FH_Conns{$$self} or return; + + if ( $fh_ref->can($what) ) { + return $fh_ref->$what(@_) + } + elsif ($GT::SQL::File::PERMIT_REFS->{$what}) { + $fh_ref->{$what} = shift if @_; + return $fh_ref->{$what}; + } + else { + return $fh_ref->error('FILE_UNKNOWNREF', 'FATAL', $what); + } +} + +sub DESTROY { +# ------------------------------------------------------------------- +# Close file handle. +# + my $self = shift; + delete $FH_Conns{$$self}; + close $self; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::File - adds file upload and download abilities to GT::SQL + +GT::SQL::File::Fh - basic file object + +=head1 DESCRIPTION + +GT::SQL::File is not created directly by the user. This module is an +internal module for GT::SQL to provide the abilty to upload/download +files into a database column (or so it seems). + +GT::SQL::File::Fh is often accessed by the user as well as created +by the user whenever the user wants to store a file in the database. + +=head2 Creating a new FILE Column + +When a new table is created or a column is converted into 'FILE' +type, two things are created. First a column of type text which will +save the name of the file that is being stored. Secondly, a +piggy-back table will be greated under the name +"parent_table_name_File". This new table will store the location of +the uploaded/stored file and various associated file attributes. + +To create a new file table, include a column something like the +following. + + File_Col_Name => { + + # common parameters + pos => 2, + type => 'FILE', + + # location of the directory where + # all the files should be saved + file_save_in => '/tmp', + + # the method all the files are saved + # 'hashed', or 'simple' + # + # Defaults to hashed, and stores files in: + # file_save_in/hashed_letter/ID + # Simple stores files in: + # file_save_in/ID_OwnName.OwnExt + file_save_scheme => 'hashed', + } ... + +=head2 Inserting into the Column + +Once you have the table created, to insert: + + # Include all the modules + use GT::SQL; + use GT::SQL::File; + + # First create a file object pointing to the file + $f = GT::SQL::File->open('/path/to/file.txt'); + + # Then create a table object + $DB = GT::SQL->new('path/to/defs'); + $tbl = $DB->table(); + + # Create the record + # the file field can also be GT::CGI::Fh type + $rec = { + File_Column => $f, + # ... and all the other columns + }; + +# optionally, if you know the path to the file, you can provide +# a scalar ref of the path and the module will autoload +# the values +# simple scalar values will be dropped + $rec = { + File_Column => \"/path/to/file.txt" + # ... and all the other columns + }; + + # Then to store the file + $id = $tbl->add( $rec ); + +=head2 Retreiving from Column + +When a file has been stored. A standard select will only return +the name of the file. + +To get a filehandle, taking the previous example, if we know the +unique id, you can do the following. + + $fh = $tbl->file_info( 'File_Column', $id ); + +You can use this file handle just like any other, however hidden +behind are special functions that can be used as follows: + + print "Content-type: ", $fh->File_MimeType(), "\n\n"; + print <$fh>; + +The following is a partial list of special functions you may access. + + + Method Returns + ------ ------- + File_Name the basic filename + File_Directory path to the file + File_MimeType mimetype of the file + File_Size site of the file + File_RelativePath the permuted file and directory without root + File_URL if possible, the URL to the requested file + File_RelativeURL the relative URL to the requested file + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: File.pm,v 1.70 2012/01/25 23:12:18 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Monitor.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Monitor.pm new file mode 100644 index 0000000..2ef9156 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Monitor.pm @@ -0,0 +1,149 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Monitor +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Monitor.pm,v 1.7 2008/12/05 01:28:49 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Monitor; +use strict; +use vars qw/@EXPORT_OK $CSS/; +use Carp qw/croak/; +use GT::CGI qw/:escape/; +require Exporter; +@EXPORT_OK = qw/query/; + +use constant CSS => <<'CSS'; + +CSS + + +sub query { +# ----------------------------------------------------------------------------- +# Handles the 'SQL Monitor' function of various Gossamer Threads products. +# Takes a hash of options: +# table - any GT::SQL table object +# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text' +# html - ('tab' or 'text' mode) whether values should be HTML escaped and the whole thing surrounded by a
         tag
        +#   query - the query to run
        +#   css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
        +# Returned is a hash reference containing:
        +#   db_prefix - the database prefix currently in use
        +#   style - the value of the 'style' option
        +#   query - the query performed
        +#   rows - the number of rows returned by the query, or possibly the number of rows affected
        +#   results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
        +#   error - set to 1 if an error occurred
        +#   error_connect - set to an error message if the database connection failed
        +#   error_prepare - set to an error message if the prepare failed
        +#   error_execute - set to an error message if the execute failed
        +#
        +    my %opts = @_;
        +
        +    $opts{table} and $opts{query} or croak "query() called without table and/or query options";
        +
        +    $opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
        +
        +    my %ret = (
        +        db_prefix => $opts{table}->{connect}->{PREFIX},
        +        style => $opts{style},
        +        query => $opts{query}
        +    );
        +
        +    my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
        +    my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
        +
        +    my $names = $sth->row_names;
        +
        +    $ret{rows} = $sth->rows || 0;
        +
        +    if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|EXPLAIN|sp_)/i) {
        +        my $table = '';
        +        my $data = $sth->fetchall_arrayref;
        +        if ($opts{style} and $opts{style} eq 'html') {
        +            $table .= defined $opts{css} ? $opts{css} : CSS;
        +            $table .= qq|\n|;
        +            $table .= "  \n";
        +            $table .= join '', map '    \n",
        +            @$names;
        +            $table .= "  \n";
        +            for (@$data) {
        +                $table .= "  \n";
        +                for (@$_) {
        +                    my $val = html_escape($_);
        +                    $val .= "
        " unless $val =~ /\S/; + $table .= qq| \n|; + } + $table .= " \n"; + } + $table .= "
        ' . html_escape($_) . "
        $val
        "; + } + elsif ($opts{style} and $opts{style} eq 'tabs') { + $table = $opts{html} ? '
        ' : '';
        +            for (@$data) {
        +                my @foo = map html_escape($_), @$_;
        +                $table .= join("\t", $opts{html} ? (map defined $_ ? html_escape($_) : '', @$_) : @$_) . "\n";
        +            }
        +            $table .= "
        " if $opts{html}; + } + else { # style = 'text' + my @max_width = (0) x @$names; + for ($names, @$data) { + for my $i (0 .. $#$_) { + my $width = length $_->[$i]; + $max_width[$i] = $width if $width > $max_width[$i]; + } + } + $table = join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + $table .= '|'; + for my $i (0 .. $#$names) { + $table .= sprintf " %-$max_width[$i]s |", $names->[$i]; + } + $table .= "\n"; + $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + for (@$data) { + $table .= '|'; + for my $i (0 .. $#$names) { + $table .= sprintf " %-$max_width[$i]s |", $_->[$i]; + } + $table .= "\n"; + } + $table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n"; + $table = "
        " . html_escape($table) . "
        " if $opts{html}; + } + $ret{results} = \$table; + } + else { + $ret{results} = "Rows affected: $ret{rows}"; + } + + return \%ret; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Relation.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Relation.pm new file mode 100644 index 0000000..635f8c5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Relation.pm @@ -0,0 +1,1897 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Relation +# Author : Jean-Michel Hiver +# $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Utility modules that makes it possible to treat joins between +# multiple tables almost as if it was a single table. +# + +package GT::SQL::Relation; +# ================================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::AutoLoader; +use strict; +use vars qw/@ISA $DEBUG $VERSION $ERROR_MESSAGE/; + +$ERROR_MESSAGE = 'GT::SQL'; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.102 $ =~ /(\d+)\.(\d+)/; + +sub DESTROY {} + +sub new { +# ----------------------------------------------------------- +# new GT::SQL::Relation ( +# tables => { table name => object } +# debug => debug level, +# _err_pkg => package name, +# ); +# ------------------------------------------------- +# Constructs (or returns if it already exists) a +# new GT::SQL::Relation object with the parameters specified +# above. +# +# +# new GT::SQL::Relation ( $hashref ); +# ---------------------------------- +# Same thing, $hashref being a reference to a +# hash which would be similar to what's above. +# +# +# $obj->new(LIST); +# ----------------- +# Internal use only. Creates a new Relation object from $obj +# with list being a subset of the tables which are being +# contained in $obj. +# + my $class = shift; + + if (ref $class) { + # if the first argument is a reference, then we assume that we + # are constructing from a Relation object that handles all the + # data that has to be passed in. + my $this = $class; + my $class = ref $class; + + my @tables = map { (ref $_) ? $_->{name} : $_ } @_; + + my $opts = {}; + $opts->{_debug} = $this->{_debug} || $DEBUG; + $opts->{_err_pkg} = $this->{_err_pkg}; + $opts->{connect} = $this->{connect}; + $opts->{tables} = { map { $_ => $this->{tables}->{$_} } @tables }; + $opts->{tables_ord} = \@tables; + + return $class->new($opts); + } + else { + my $self = bless {}, $class; + my $opts = {}; + + if (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift } + elsif (@_ % 2 == 0) { $opts = { @_ } } + else { + $self->error("BADARGS", "FATAL", "new GT::SQL::Relation (HASH or HASHREF)"); + } + + # same thing for name - must be an array ref + ref $opts->{tables} eq 'HASH' or + return $self->error("BADARGS", "FATAL", "$class new(HASH_REF or HASH). name must be a ref to a list of table names."); + + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} if exists $opts->{_err_pkg}; + $self->{tables} = $opts->{tables}; + $self->{connect} = $opts->{connect}; + $self->{fk} = {}; + + # if an order was specified for the tables, use it, otherwise + # sort the tables in lexicographical order. + my @tables_ord = sort keys %{$self->{tables}}; + if ($opts->{tables_ord}) { @tables_ord = @{$opts->{tables_ord}} } + + $self->{tables_ord} = \@tables_ord; + + # this is a hash that has { $table names => $schema object } + $self->{last_where} = undef; + $self->{last_hits} = undef; + $self->debug("OBJECT CREATED") if ($self->{_debug} > 2); + return $self; + } +} + +# ------------------------------------------------------------------------------------- # +# INSERT # +# ------------------------------------------------------------------------------------- # + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $obj->insert($col1 => $val1, +# ..., +# $coln => $valn, +# ); +# ----------------------------- +# Will fill +# the tables whenever it can according to the +# insert parameters. +# +# returns TRUE if insert succeeded, +# FALSE otherwise. +# +# $obj->insert($hashref); +# ------------------------------ +# Same as above. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_insert($split); + if (! $added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +$COMPILE{add} = __LINE__ . <<'END_OF_SUB'; +sub add { +# ----------------------------------------------------------- +# add() : Adds a record into the current relation object, and +# returns a hash of primary key => value. +# + my $self = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + + my $input = {}; + foreach my $key (keys %$opts) { + $input->{$key} = $opts->{$key}; + } + my $split = $self->_split_schema($input); + my $added = $self->_add($split); + if (!$added) { + $self->{_error} ||= []; + for (values %{$self->{tables}}) { + if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) { + push(@{$self->{_error}}, @{$_->{_error}}); + } + } + return; + } + return $added; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# SELECT # +# ------------------------------------------------------------------------------------- # + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where +# condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that +# you wish returned. If none are specified all +# fields will be returned. +# + my $self = shift; + $self->connect or return; + +# Get a list of fields to select. + my (@fields, @cond, $left_join); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_}; } + elsif (not ref $_) { ($_ eq 'left_join') ? ($left_join = 1) : push @fields, $_; } + else { push @cond, $self->_build_cond($_); } + } + @fields = map { $self->_complete_name($_) } grep { defined and length } @fields; + @fields or (@fields = ('*')); + + my $fields = join ',' => @fields; + my $condition = @cond > 1 ? GT::SQL::Condition->new(@cond) : $cond[0]; + +# building the join condition for this query + my @relations = values %{$self->{tables}}; + my $join = $self->_join_query(\@relations); + +# building the select options, if any + my $sel_opts = ''; + if (defined $self->select_options) { $sel_opts = " " . join " ", $self->select_options } + $self->{sel_opts} = undef; + +# Any fk specifics + $self->{fk} ||= {}; + my $orig_fk = {}; + for my $table (keys %{$self->{fk}}) { + if (defined $self->{fk}->{$table}) { + $orig_fk->{$table} = $self->{fk}->{$table}; + $self->{tables}->{$table}->{schema}->{fk}->{$table} = $self->{fk}->{$table}; + } + } + + my $sql; + if ($left_join) { + my $tables = $self->{tables_ord}->[0] . ' LEFT OUTER JOIN ' . $self->{tables_ord}->[1] . ' ON ' . $join; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "WHERE ($string)" if $string; + } + + $sql = qq!SELECT $fields FROM $tables $cond_sql!; + $sql .= $sel_opts if $sel_opts; + } + else { + my $tables = join ',' => sort keys %{$self->{tables}}; + my $cond_sql = ''; + if (defined $condition) { + my $string = $condition->sql; # may be empty, never be paranoid enough + $cond_sql = "($string)" if $string; + } + + my $where = ($cond_sql or $join) ? "WHERE " : ""; + $where .= "$join " if $join; + $where .= 'AND ' if $join and $cond_sql; + $where .= "$cond_sql" if $cond_sql; + $sql = qq!SELECT $fields FROM $tables $where!; + $sql .= $sel_opts if $sel_opts; + } + + my $sth = $self->{driver}->prepare($sql) or return; + $sth->execute or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it now +# without an additional query. + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined($3)) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif ($1) { + ($limit, $offset) = ($1, $2 || 0); + } + else { + ($offset, $limit) = ($4, $5); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + + $self->{sel_opts} = []; + +# Save the last query for future use. + $self->{last_where} = $condition ? $condition->clone : undef; + + for ( keys %$orig_fk ) { + $self->{tables}->{$_}->{schema}->{fk}->{$_} = $orig_fk->{$_}; + } + $self->{fk} = {}; + return $sth; +} + +$COMPILE{join_on} = __LINE__ . <<'END_OF_SUB'; +sub join_on { +# ------------------------------------------------------------------- +# Change how tables join + my ( $self, $tb, %change ) = @_; + my $p = $self->prefix; + $tb = $p . $tb; + return unless exists $self->{tables}{$tb}; + for my $table ( keys %change ) { + my $cp = $p . $table; + next unless exists $self->{tables}{$cp}; + $self->{tables}->{$tb}->{schema}->{fk}->{$cp} = $change{$table}; + } +} +END_OF_SUB + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + my %join; + foreach my $relation (@$relations) { + my $relation_name = $relation->{name}; + my @join_tables = keys %{$relation->{schema}->{fk}}; + foreach my $join_table (@join_tables) { + if ($self->{tables}->{$join_table}) { + my $fk = $relation->{schema}->{fk}->{$join_table}; + for my $key (keys %$fk) { + $join{"$relation_name.$key"} = "$join_table.$fk->{$key}" unless $relation_name eq $join_table; # Ignore foreign keys to the same table + } + } + } + } + return join " AND ", map "$_ = $join{$_}", keys %join; +} + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want +# prepended to your search. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_ > 0; + if (wantarray) { ($self->{sel_opts}) ? @{$self->{sel_opts}} : () } + else { ($self->{sel_opts}) ? $self->{sel_opts} : [] } +} + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ----------------------------------------------------------- +# $obj->query($HASH or $CGI); +# ---------------------------- +# Performs a query based on the options in the hash. +# $HASH can be a hash ref, hash or CGI object. +# +# Returns the result of a query as fetchall_arrayref. +# + my $self = shift; + my $sth = $self->_query(@_) or return; + return $sth->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ----------------------------------------------------------- +# $obj->query_sth($HASH or $CGI); +# -------------------------------- +# Same as query but returns the sth object. +# + shift->_query(@_) +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# DELETE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{delete} = __LINE__ . <<'END_OF_SUB'; +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition, $opt); +# -------------------------------- +# $condition is a condition on the current +# join relation, +# +# $opt is a string which can be either 'abort', +# 'ignore', or 'cascade'. +# + my $self = shift; + my $cond = shift; + my $opt = shift || 'cascade'; + + $cond = $self->_build_cond($cond); + + $self->{last_where} = $cond ? $cond->clone : undef; + + my $rows; + if ($opt eq 'ignore') { + my $split = $self->_split_fields($cond); + for (keys %{$split}) { + $rows += $self->{$_}->delete($split->{$_}, 'ignore') or return; + } + } + elsif ($opt eq 'abort') { + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, $cond) or return; + if (!$q->rows) { + $rows = "0E0" unless ($q->rows); + } + else { + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + foreach my $referencing ($self->_referencing_relations) { + unless ($self->_can_delete($h, $referencing)) { + return $self->error("DEPENDENCY", "WARN", $referencing); + } + } + } + $rows = $self->_delete_cascade($cond->new_clean); + } + } + elsif ($opt eq 'cascade') { + $rows = $self->_delete_cascade($cond) or return; + } + return ($rows == 0) ? '0E0' : $rows; +} +END_OF_SUB + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# deletes all the records in this relation +# + my $self = shift; + my $opt = shift || 'abort'; + foreach my $rel ($self->_referencing_relations) { ($rel->delete_all($opt)) ? next : return } + foreach my $rel ($self->_referenced_relations) { ($rel->delete_all($opt)) ? next : return } + return 1; +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# UPDATE # +# ------------------------------------------------------------------------------------- # + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# ----------------------------------------------------------- +# $obj->update($hashref, $hashref); +# $obj->update($hashref, $condition); +# ------------------------------------ +# $hashref are the fields to update +# +# $condition is a condition on the current +# join relation. +# +# A limitation exists: in a relation one to many, +# it is not possible to perform an update on the +# attributes that are in the "one" entity. +# + my ($self, $hash, $cond) = @_; + (ref $self and ref $hash and ref $cond) or $self->error("BADARGS", "FATAL", '$obj->update(HASH, GT::SQL::Condition or HASH)'); + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + $cond = $self->_build_cond($cond); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + my ($upd, $rec) = ($hash->{$rel->{name}}, $h); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec2 = {}; + my $prefix = $rel->{name} . "."; + foreach my $col (keys %{$rel_rec}) { + my $col2 = $col; + $col2 =~ s/^\Q$prefix\E//; + $rel_rec2->{$col2} = $rel_rec->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + + unless (defined $rel->update($upd, $rel_rec2)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + + my $in = $self->common_param(@_); + + # first of all complete $in attributes + my ($hash, $cond); + for my $col (keys %$in) { + if (my $completed = $self->_complete_name($col, 1)) { + $hash->{$completed} = $in->{$col}; + } + } + + # let's build the $condition + my $condition = { map { + $_ => $hash->{$_} + } $self->pk }; + + $hash = $self->_split_schema($hash); + +# removes noise values from _split_schema + foreach my $rel_name (keys %{$hash}) { + my $h = $hash->{$rel_name}; + if (defined $h) { + foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) } + delete $hash->{$rel_name} unless (keys %{$h}); + } + else { + delete $hash->{$rel_name}; + } + } + + my @ordered_columns = $self->col_names; + + $cond = $self->_build_cond($condition); + $self->{last_where} = $cond ? $cond->clone : undef; + + my $q = $self->select(\@ordered_columns, $cond) or return; + my @err = (); + while (my $array = $q->fetchrow_arrayref) { + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i] + } + + + for my $rel (values %{$self->{tables}}) { + next unless defined $hash->{$rel->{name}}; + +# from $rel_rec, a hashref needs to be built that isn't prefixed +# by the table name because GT::SQL::Table doesn't understand that + my $rel_rec = {}; + foreach my $col (keys %{$h}) { + next unless $col =~ /^\Q$rel->{name}\E\./; + my $col2 = $col; + $col2 =~ s/^[^.]+\.//; + $rel_rec->{$col2} = defined($hash->{$rel->{name}}->{$col2}) ? $hash->{$rel->{name}}->{$col2} : defined($hash->{$rel->{name}}->{$col}) ? $hash->{$rel->{name}}->{$col} : $h->{$col}; + } + + $self->debug("Calling $rel->update") if ($self->{_debug} > 2); + unless (defined $rel->modify($rel_rec)) { + if ($GT::SQL::errcode eq 'UNIQUE') { + next; + } + push @err, $GT::SQL::error; + } + } + } + if (@err) { + $GT::SQL::error = join "\n", @err; + return; + } + else { return 1 } +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# COUNT/GET # +# ------------------------------------------------------------------------------------- # + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# $obj->get($condition, $opt); +# ----------------------------- +# $condition is the condition for the row that has to be +# retrieved. $opt can be 'ARRAY' or 'HASH'. The first row +# of the query is returned, which makes the get method +# mostly useful to retrieve rows from the primary key +# values. +# + my $self = shift; + my $cond = shift; + if (ref $cond eq 'ARRAY') { $cond = { @{$cond} } } + my $method = shift || 'HASH'; + $method = (uc $method eq 'ARRAY') ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond) or return; + return $sth->$method(); +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# ACCESSSORS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the relation columns as a hash which has +# the columns names as a key and their type as a +# value. +# + my $self = shift; + my @res; + if (@_) { $self->error('BADARGS', 'FATAL', '$obj->cols;') } + +# if the number of table objects that handles the current +# relation object equals zero, then returns an empty hash. + my @names = $self->name; + if (@names == 0) { return {} } + else { + my $res = {}; + my @referencing = $self->_referencing_relations; + my @referenced = $self->_referenced_relations; + if (@referenced) { + +# if in the current Relation object there exists some +# tables which are referenced by other tables within +# the current relation object, then + my %referenced_cols = $self->new(@referenced)->cols; + my @referenced_cols = keys %referenced_cols; + +# remove columns which are referenced by referencing +# tables because we don't wanna have these duplicates. + my @rem_cols; + foreach my $referencing (@referencing) { + foreach my $target (keys %{$referencing->{schema}->{fk}}) { + if (defined $self->{tables}->{$target}) { + push @rem_cols, map { $target .'.'. $_ } keys %{$referencing->{schema}->{fk}->{$target}}; + } + } + } + my @cols_left = _minus(\@referenced_cols, \@rem_cols); + map { $res->{$_} = $referenced_cols{$_} } @cols_left; + } + +# add then all low level columns, and return. + foreach my $referencing (@referencing) { + my %referencing_cols = %{$referencing->{schema}->{cols}}; + map { $res->{$referencing->{name} .'.'. $_} = $referencing_cols{$_} } keys %referencing_cols; + } + + return $res unless wantarray; + +# Wantarray has been set so create a copy of the res whose +# first and second level references can be clobbered. +# This assumes that the values side of the res will +# always been hashrefs + my %res_copy = %$res; + foreach my $res_name ( keys %res_copy ) { + + my %res_data = %{$res_copy{$res_name}}; + $res_copy{$res_name} = \%res_data; + + foreach ( keys %res_data ) { + if ( ref $res_data{$_} eq 'HASH' ) { + $res_data{$_} = {%{$res_data{$_}}}; + } + elsif ( ref $res_data{$_} eq 'ARRAY' ) { + $res_data{$_} = [@{$res_data{$_}}]; + } + } + } + + return %res_copy; + } +} +END_OF_SUB + +$COMPILE{col_names} = __LINE__ . <<'END_OF_SUB'; +sub col_names { +# ----------------------------------------------------------- +# Returns the columns names sorted the right order. +# + my $self = shift; + my %cols = $self->cols; + return sort { my $ret = $self->_col_cmp($a, $b); $ret } keys %cols; +} +END_OF_SUB + +# self explainatory +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { return shift->col_names(@_) } +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns a list of current relation names +# +# $obj->name(@names); +# -------------------- +# Returns a list of objects maching specified name. +# + my $self = shift; + if (@_) { + return map $self->{tables}->{$_}, @_ + } + else { + my @names = keys %{$self->{tables}}; + return wantarray ? @names : \@names; + } +} + +$COMPILE{unique} = __LINE__ . <<'END_OF_SUB'; +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns an array containing all the array refs +# for all the uniques. +# +# $obj->unique($field_name); +# --------------------------- +# Returns true if the field is unique. False otherwise. +# + my $self = shift; + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my %unq = %{$table->{schema}->{unique}}; + foreach my $unq (values %unq) { push @res, [ map { $table_name . "." . $_ } @{$unq} ] } + } + if (@_ == 1) { + my $s = shift; + return scalar grep { $s eq $_ } map { @{$_} } @res; + } + return wantarray ? @res : \@res; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns an array containing all the array refs +# for all the indexes. +# + my $self = shift; + if (@_ == 0) { + my @res = (); + foreach my $table_name (sort keys %{$self->{tables}}) { + my $table = $self->{tables}->{$table_name}; + my @idx = values %{$table->{schema}->{index}}; + foreach my $idx (@idx) { push @res, [ map { $table_name . "." . $_ } @{$idx} ] } + } + return wantarray ? @res : \@res; + } + else { return $self->error('BADARGS', 'FATAL', '$obj->index;') } +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# This method returns the columns reprensenting what +# would be the primary key of our JoinRelation if it +# ever existed. +# +# Tables which are referenced by other tables primary +# key shall not be exported, because they are the 'one' +# entities in a one-to-many relation. +# +# $obj->pk($field_name); +# ----------------------- +# Returns true if the field is in the primary +# key list. Returns false otherwise. +# + my $self = shift; + if (@_ == 0) { + my @result = (); + my @referencing = $self->_referenced_relations; + foreach my $referencing (@referencing) { push @result, map { $referencing->{name} .'.'. $_ } @{$referencing->{schema}->{pk}}; } + return sort { my $ret = $self->_col_cmp($a, $b); $ret; } @result; + } + elsif (@_ == 1) { + my $name = $self->_complete_name(shift); + return scalar grep { $name eq $_ } @{$self->{schema}->{pk}}; + } + else { $self->error('BADARGS', 'FATAL', '$obj->pk;') } +} +END_OF_SUB + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# returns a list of relation names which are referenced +# by the current relation. +# +# $obj->fk(RELATION_NAME); +# ------------------------- +# returns a hashref for relation RELATION_NAME which +# keys are the current relation "source" schema and which +# values are the "target" schema. +# + my $self = shift; + if (@_ > 1) { $self->error('BADARGS', 'FATAL', '$obj->fk; or $obj->fk($table_name)') } + if (@_ == 1) { + my $res = {}; + my $target = shift; + foreach my $rel (values %{$self->{tables}}) { + foreach my $rel_target (keys %{$rel->{schema}->{fk}}) { + if ($target eq $rel_target) { + my $h = $rel->{schema}->{fk}->{$rel_target}; + foreach my $k (keys %{$h}) { $res->{$rel->{name} .'.'. $k} = $h->{$k} } + } + } + } + return wantarray ? %{$res} : $res; + } + else { + my @res; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + push @res, $fk unless ($self->{tables}->{$fk}); + } + } + return wantarray ? @res : \@res; + } +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# $obj->fk_tables; +# ---------------- +# Returns a list of table that reference any +# of the table that's in the current joinrelation. +# +# $obj->fk_tables($table_name); +# ------------------------------ +# Returns true if $table_name is the name of a +# table that's referencing any of the tables that's +# in the current joinrelation. +# + my $self = shift; + my @result = $self->_minus( [ map { @{$_->{schema}->{fk_tables}} } values %{$self->{tables}} ], [ $self->name ] ); # very evil (c) + if (@_ == 1) { + my $check = shift; + return scalar grep { $check eq $_ } @result; + } + return wantarray ? @result : \@result; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + return wantarray ? [@{$self->unique}, @{$self->index}] : @{$self->unique}, @{$self->index}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# ai makes no sense in a Relation therefore I return nothing +# + my $self = shift; + my @res; + foreach my $rel (values %{$self->{tables}}) { + my $ai = $rel->{schema}->{ai} or next; + $ai = $rel->{name} . '.' . $ai; + push @res, $ai; + } + return unless @res; + return wantarray ? @res : \@res; + +} +END_OF_SUB + +# ------------------------------------------------------------------------------------- # +# INTERNAL METHODS # +# ------------------------------------------------------------------------------------- # + +$COMPILE{_build_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_cond { +# ----------------------------------------------------------- +# this subroutine is made to build conditions which may not +# be a Condition object for selects and deletes. +# + my ($self, $condition) = @_; + my $prefix = $self->{connect}->{PREFIX}; + if (! defined $condition) { + return; + } + elsif (ref $condition eq 'HASH') { + my $tmp = new GT::SQL::Condition; + while (my ($col, $val) = each %$condition) { + $col = $self->_complete_name($col); + $tmp->add($col => '=' => $val); + } + return $tmp; + } + elsif (ref $condition eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$condition}); + return $tmp; + } + elsif (length $prefix and (ref $condition eq 'GT::SQL::Condition')) { + $self->_build_prefixed_cond($prefix, $condition); + return $condition; + } + else { + return $condition; + } +} +END_OF_SUB + +$COMPILE{_build_prefixed_cond} = __LINE__ . <<'END_OF_SUB'; +sub _build_prefixed_cond { +# ----------------------------------------------------------- +# $obj->_build_prefixed_cond($prefix, $cond) +# --------------------------------- +# + my ($self, $prefix, $condition) = @_; + foreach (@{$condition->{cond}}) { + if (ref $_ eq 'ARRAY') { + if ($_->[0] =~ /^[\w\.]+$/) { + $_->[0] = $self->_complete_name($_->[0]); + } + } + elsif (ref $_ eq 'GT::SQL::Condition') { + $self->_build_prefixed_cond($prefix, $_); + } + } + return $condition; +} +END_OF_SUB + +$COMPILE{_complete_name} = __LINE__ . <<'END_OF_SUB'; +sub _complete_name { +# ----------------------------------------------------------- +# Returns a Table.Attribute name of a column given Attribute, if possible. +# Takes an optional second argument - if passed and true, seeing 'abc.xyz' will +# return undef if 'abc' isn't a valid table. Without the true second argument, +# such a situation causes a fatal error. +# + my $self = shift; + my $col = shift or return $self->error('BADARGS', 'FATAL', "No column name specified."); + my $ignore_unknown = shift; + +# if column name is a scalar reference, just throw in the raw colname + ref $col eq 'SCALAR' and return $$col; + +# try to handle fully qualified column names + my ($relname, $colname) = split /\./, $col; + if ($relname and $colname) { + if (exists $self->{tables}->{$relname}) { + return $col; + } + else { + my $prefix = $self->{connect}->{PREFIX}; + if (exists $self->{tables}->{$prefix.$relname}) { + return $prefix.$relname.".".$colname; + } + elsif ($ignore_unknown) { + return undef; + } + else { + return $self->error('BADCOLS', 'FATAL', $col); + } + } + } + +# Otherwise, no . in column name. + my $found = 0; + my $return = $col; + foreach my $rel (values %{$self->{tables}}) { + my %h = %{$rel->{schema}->{cols}}; + if (exists $h{$col}) { + $found++; + $return = $rel->{name} . '.' . $col; + } + } + if ($found > 1) { + return $self->error('BADCOLS', 'FATAL', $col); + } + return $return; +} +END_OF_SUB + +$COMPILE{_col_cmp} = __LINE__ . <<'END_OF_SUB'; +sub _col_cmp { +# ----------------------------------------------------------- +# $a is something like TABLE.COL +# this method is used to sort the columns in the right order. +# + my ($self, $a, $b) = @_; + + $a and !$b and return -1; + $b and !$a and return 1; + !$a and !$b and return 0; + + my $one = $self->_complete_name($a); + my $two = $self->_complete_name($b); + my ($one_tab, $one_col) = split /\./, $one; + my ($two_tab, $two_col) = split /\./, $two; + + if ($one_tab eq $two_tab) { + return 0 if (!$one_tab or !$two_tab); + return ($self->{tables}->{$one_tab}->{schema}->{cols}->{$one_col}->{pos} <=> $self->{tables}->{$one_tab}->{schema}->{cols}->{$two_col}->{pos}); + } + else { + my @tables_ord = @{$self->{tables_ord}}; + while (my $table = shift(@tables_ord)) { + if ($table eq $one_tab) { return -1 } + if ($table eq $two_tab) { return 1 } + } + return 0; + } +} +END_OF_SUB + +$COMPILE{_insert} = __LINE__ . <<'END_OF_SUB'; +sub _insert { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $sth = $rel->insert($split->{$rel->{name}}) or return; + unless ($sth) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $sth = $rel->insert(%{$split->{$name}}); + unless ($sth) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $column_hash (values %added) { + foreach my $col (keys %{$column_hash}) { + $ids{$col} = $column_hash->{$col}; + } + } + return \%ids; +} +END_OF_SUB + +$COMPILE{_add} = __LINE__ . <<'END_OF_SUB'; +sub _add { +# ----------------------------------------------------------- +# $obj->_insert($split); +# -------------------------------- +# Inserts a record in the current Relation +# inserting where it's possible to. +# + my $self = shift; + my $split = shift; + my @referenced = $self->_referenced_relations; + my @referencing = $self->_referencing_relations; + + my (%added, $err); + foreach my $rel (@referenced) { + $self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return; + my $id = $rel->add($split->{$rel->{name}}) or return; + unless ($id) { + my $errcode = $GT::SQL::errcode; + if ($errcode ne 'UNIQUE') { $err = 1; last } + else { next } + } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$rel->{name}}; + } + } + if ($err) { + + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + foreach my $rel (@referencing) { + my %fk = %{$rel->{schema}->{fk}}; + my $name = $rel->{name}; + + for my $ft (keys %fk) { + if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) { + my $h = $fk{$ft}; + my $rec = $self->{tables}->{$ft}; + for (keys %{$h}) { + unless ($split->{$name}->{$_}) { + if ($h->{$_} eq $rec->{schema}->{ai}) { + $split->{$name}->{$_} = $added{$ft}->{$h->{$_}}; + } + } + } + } + } + my $id = $rel->add($split->{$name}); + unless ($id) { $err = 1; last; } + if ($rel->{schema}->{ai}) { + $added{$rel->{name}} = { $rel->{schema}->{ai} => $id }; + } + else { + $added{$rel->{name}} = $split->{$name}; + } + } + if ($err) { + for my $rel_name (keys %added) { + my $rel = $self->{tables}->{$rel_name}; + my $id = $added{$rel_name}; + $rel->delete($id); + } + return; + } + +# Return a hash ref of primary key => value. + my %ids; + foreach my $table_name ( keys %added ) { + foreach my $col (keys %{$added{$table_name}}) { + $ids{"$table_name.".$col} = $added{$table_name}->{$col}; + } + } + + return \%ids; +} +END_OF_SUB + +$COMPILE{_minus} = __LINE__ . <<'END_OF_SUB'; +sub _minus { +# ----------------------------------------------------------- +# _minus($ary1, $ary2); +# ---------------------- +# $ary1 and $ary2 being two array refs, +# returns a list of all elements in $ary1 +# which are not in $ary2. +# + my ($self, $ary1, $ary2); + if (@_ == 0 || @_ == 1) { return } + elsif (@_ == 2) { ($ary1, $ary2) = @_ } + else { ($self, $ary1, $ary2) = @_ } + my @a1 = @{$ary1}; + my @a2 = @{$ary2}; + my @result; + foreach my $elt1 (@a1) { + my $push = 1; + foreach my $elt2 (@a2) { + $push = 0 if ($elt1 eq $elt2); + } + push @result, $elt1 if ($push == 1); + } + return @result; +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ----------------------------------------------------------- +# $self->_query; +# -------------- +# This function takes in special query arguments and turns them +# into a $opts array before doing the actual select on the +# database. +# + my $self = shift; + scalar $self->name() or return $self->error("NOTABLE", "FATAL"); + my $opts = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->_query( HASH or HASH_REF or CGI ) only.'); + + +# Strip out values that are empty or blank (as query is generally +# derived from cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} =~ /\S/ } keys %$opts; + $opts = \%input; + +# Prefix column names. + foreach my $field (keys %$opts) { + if ($field =~ /^(.*)-(gt|lt|le|ge|opt)$/) { + my $opt = $2; + if (my $full = $self->_complete_name("$1", 1)) { + $opts->{"$full-$opt"} = $opts->{$field}; + } + } + else { + if (my $full = $self->_complete_name($field, 1)) { + $opts->{$full} = $opts->{$field}; + } + } + } + +# Set search options and get query condition. + my $in = $self->_get_search_opts($opts); + my $cond = $self->build_query_cond($opts, scalar $self->cols); + + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless ($in->{mh} == -1); + my @sel = (); + if ($cond) { push @sel, $cond } + if ($in->{rs} and $cond) { push @sel, $in->{rs} } + if ($opts->{left_join} and $cond) { push @sel,'left_join' } + my $sth = $self->select(@sel) or return; + return $sth; +} +END_OF_SUB + +$COMPILE{_split_schema} = __LINE__ . <<'END_OF_SUB'; +sub _split_schema { +# ----------------------------------------------------------- +# $obj->_split_schema($hashref); +# ------------------------------- +# Turns { Table1.Attribute1 => value1, +# Table1.Attribute2 => value2, +# Table2.Attribute1 => value3 } +# +# into { Table1 => { Attribute1 => value1, +# Attribute2 => value2 } +# Table2 => { Attribute1 => value1 } } +# +# $obj->_split_schema($col1 => $val1, +# ..., +# $coln => $valn); +# +# it also looks if a field is referencing +# another, and if so duplicates the field +# key and value in the target table provided +# that this target table is in the current +# relation object. +# + my $self = shift; + my $arg; + if (ref $_[0] eq 'HASH') { $arg = shift } + elsif (not @_ % 2 and defined $_[0]) { $arg = {@_} } + else { return $self->error('BADARGS', 'FATAL', '$self->_split_schema(%hash)') } + my $result = {}; + +# first of all, some of the fields may not be specifying +# the table they belong to. + foreach my $col (keys %{$arg}) { + if (my $relname = $self->_complete_name($col, 1)) { + $arg->{$relname} = delete $arg->{$col}; + } + } + +# then, we separate fields in function of +# the table name that they have. + foreach my $complete_field (keys %{$arg}) { + next if (CORE::index($complete_field, '.') == -1); + my ($tablename, $fieldname) = split /\./, $complete_field; + $result->{$tablename} = {} unless (defined $result->{$tablename}); + $result->{$tablename}->{$fieldname} = $arg->{$complete_field}; + } + +# then, for each relation in our join object, complete +# names in $result + foreach my $relation (values %{$self->{tables}}) { + my $relation_name = $relation->{name}; + + # for all $relation foreign keys which are in $self + my %target_relation_names = %{$relation->{schema}->{fk}}; + + foreach my $target_relation_name (keys %target_relation_names) { + + # if the target relation exists in our join relation + # object and in our $hash + if (defined $self->{tables}->{$target_relation_name} and defined $result->{$target_relation_name}) { + + # then in $hash we set the values of the fields + # for the target relation depending on the values + # of the source relation. + my $fk = $relation->{schema}->{fk}->{$target_relation_name}; + foreach my $key (keys %{$fk}) { + my $value = $fk->{$key}; + $result->{$target_relation_name} = {} unless defined $result->{$target_relation_name}; + + my $fk_key = $relation->{schema}->{fk}->{$target_relation_name}->{$key}; + $result->{$relation_name}->{$key} = $result->{$target_relation_name}->{$fk_key} + if defined $result->{$target_relation_name}->{$fk_key}; + } + } + } + } + return $result; +} +END_OF_SUB + +$COMPILE{_referenced_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referenced_relations { +# ----------------------------------------------------------- +# $obj->_top_level_relations; +# --------------------------- +# This method returns the relations in the current +# which are referenced by other tables in the current join +# relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + my @referenced = _minus([ values %{$self->{tables}} ], [ map {$self->{tables}->{$_}} keys %names ]); + return @referenced; +} +END_OF_SUB + +$COMPILE{_referencing_relations} = __LINE__ . <<'END_OF_SUB'; +sub _referencing_relations { +# ----------------------------------------------------------- +# $obj->_referencing_relations; +# ----------------------------- +# This method returns the tables in the current +# relation which are not referenced by any other +# tables in this relation. +# + my $self = shift; + my %names = map { $_ => 1 } keys %{$self->{tables}}; + foreach my $rel (values %{$self->{tables}}) { + foreach my $fk (keys %{$rel->{schema}->{fk}}) { + delete $names{$fk} unless ($fk eq $rel->{name}) + } + } + return map {$self->{tables}->{$_}} keys %names; +} +END_OF_SUB + +$COMPILE{_delete_cascade} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cascade { +# ----------------------------------------------------------- +# $obj->_delete_cascade($cond); +# ------------------------------ +# This method is used internaly to delete all the rows +# that match $cond for that joinrelation object. +# + my $self = shift; + my $count = 0; + + my @ordered_columns = $self->col_names; + my $q = $self->select(\@ordered_columns, @_) or return; + while (my $array = $q->fetchrow_arrayref) { + $count++; + +# for each row that matches the condition + my $h = {}; + for (my $i = 0; $i < @ordered_columns; $i++) { + $h->{$ordered_columns[$i]} = $array->[$i]; + } + +# delete each low-level table rows (i.e. referencing tables) + foreach my $referencing ($self->_referencing_relations) { + $self->_delete_row($h, $referencing); + } + +# then delete each top-level table rows, if possible +# this may be broken when using tables with hierarchy +# level > 2. + foreach my $referenced ($self->_referenced_relations) { + if ($self->_can_delete($h, $referenced)) { $self->_delete_row($h, $referenced) } + } + } + return $count == 0 ? "0E0" : $count; +} +END_OF_SUB + +$COMPILE{_can_delete} = __LINE__ . <<'END_OF_SUB'; +sub _can_delete { +# ----------------------------------------------------------- +# $obj->_can_delete($record, $relation); +# --------------------------------------- +# Returns true if the record can be deleted +# from this relation without breaking dependancies +# or false otherwise. +# + my ($self, $rec, $rel) = (@_); + ref $rel or $rel = $self->{tables}->{$rel}; + + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + +# for all the schemas that exist in the database + foreach my $schema (keys %GT::SQL::Table::DATABASE) { + $self->debug("CREATING A NEW TABLE OBJECT") if ($self->{_debug} > 2); + + my $relation = $self->new_table($schema); + foreach my $relation_targetname ($relation->{schema}->{fk}) { + if ($relation_targetname eq $rel->{name}) { + my $schem = $relation->{schema}->{fk}->{$relation_targetname}; + +# I must make a copy of this because it's a reference from Schema +# and can potentially be used later, therefore it should not be +# modified. + my $schema = { map { $_ => $schem->{$_} } keys %{$schem} }; + foreach my $key (keys %{$schema}) { $schema->{$key} = $rel_rec->{$schema->{$key}} } + $relation->count($schema) and return 0; + } + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_row} = __LINE__ . <<'END_OF_SUB'; +sub _delete_row { +# ----------------------------------------------------------- +# $obj->_delete_row($record, $relation); +# --------------------------------------- +# + my ($self, $rec, $rel) = (@_); + my $allrec = $self->_split_schema($rec); + my $rel_rec = $allrec->{$rel->{name}}; + foreach my $col (keys %{$rel_rec}) { delete $rel_rec->{$col} unless (defined $rel_rec->{$col}) } + $rel->delete($rel_rec, 'cascade'); +} +END_OF_SUB + +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { +#------------------------------------------------------------------------------- + my $self = shift; + $_[0] and $self->{_file_cols} = undef; + $self->{_file_cols} and return %{$self->{_file_cols}}; + my %rec = (); + for my $table_name ( keys %{$self->{tables} } ) { + my %trec = $self->{tables}->{$table_name}->_file_cols() or next; + $rec{$table_name} = \%trec; + } + return %rec; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Relation - manage multiple table joins + +=head1 SYNOPSIS + + my $relation = $DB->table('Company', 'Employees'); + my $sth = $relation->select( { + Company.Name => 'Gossamer Threads', + Employees.Name => 'Alex Krohn' + }, ['Employees.Salary', 'Company.City'] ); + my ($salary, $city) = $sth->fetchrow_array; + print "Alex works in $city and earns $salary!\n"; + +=head1 DESCRIPTION + +This module aims at emulating a set of tables that are related to each other +via the use of foreign keys just as if it was one big table. + +The module interface should be as compatible as possible with GT::SQL::Table, +thus you should be familiar with GT::SQL::Table before even reading this. + +This documentation explains the differences between GT::SQL::Relation and +GT::SQL::Table and how the module internally works as well. + +=head2 How it works + +GT::SQL supports the concept of foreign keys (also known as external +references). Basically, two tables that are linked together using external +references can look like that: + + .-------------. .---------. + | EMPLOYEE | | COMPANY | + `-------------' `---------' + | ID | .--->ID | + | COMPANY_ID ----' | NAME | + | NAME | `---------' + | SALARY | + `-------------' + +In this example, the COMPANY_ID attribute relates the fact that a an EMPLOYEE +belongs to such or such COMPANY. + +Utilizing a Relation object can make these tables look like that: + + .----------------------. + | EMPLOYEE-COMPANY | + `----------------------' + | EMPLOYEE.ID | + | EMPLOYEE.COMPANY_ID | + | EMPLOYEE.NAME | + | EMPLOYEE.SALARY | + | COMPANY.NAME | + `----------------------' + +The first thing that can be seen from there is that COMPANY.ID has disappeared +from this "Virtual" table. + +Indeed, as for a given "joined" record this value must be the same in both +tables, representing the values twice would have been a useless source of +confusion. + +=head2 SELECT statements + +Selecting from a Relation object is pretty simple using the GT::SQL module. As +the interface is (almost) the same as L, the GT::SQL wrapper +returns Table or Relation objects depending on the arguments that are passed to +table. + + # This gives me a GT::SQL::Table object for + # the EMPLOYEE table. + my $emp = $sql->table('EMPLOYEE'); + + # This gives me a GT::SQL::Relation object for + # the relation EMPLOYEE-COMPANY tables + my $emp_cmp = $sql->table('EMPLOYEE','COMPANY'); + +From there, performing a select is pretty simple: + + # select all the people from a real cool company + my $sth = $emp_cmp->select( { COMPANY.NAME => "Gossamer Threads" } ) + +Internally, the generated SQL query would look like: + + SELECT EMPLOYEE.ID, EMPLOYEE.COMPANY_ID, EMPLOYEE.NAME + EMPLOYEE.SALARY, COMPANY.NAME + FROM EMPLOYEE, COMPANY + WHERE COMPANY.NAME = 'Gossamer Threads' AND + EMPLOYEE.COMPANY_ID = COMPANY.ID + +Note that the join condition is computed and automatically appended at the end +of the query, so you do not have to worry about this. + +=head2 SELECT options + +The select options for relation are similar to that of table, you have +select_options() which will be set for the next query done. Example: + + $relation->select_options("LIMIT 10"); + +This would append 'LIMIT 10' to your next select query. Another useful thing +is join_on(). join_on() allows you to specify the FK relation for the nextr +select. This overrides what is in the def files. It is useful for allowing you +to have one table which will be join differently depending on what you are +doing. The argument to this are the same as to fk(). +Example: + + $relation->join_on( remote_table => { local_column => remote_column } ); + +The FK relation will be changed to this the next time you call select() but +then it will be cleared. + +=head2 Listing the relation columns + +* As previously said, the cols() method when invoked on a GT::SQL::Relation +object does not return all the columns, removing the duplicate external +references. So, how does it decides which column to keep and which one to +return? + +In the EMPLOYEE-COMPANY example we have the constraint +EMPLOYEE.COMPANY_ID => COMPANY.ID and it keeps COMPANY_ID, i.e. the foreign key +instead of the key itself. + +=head2 Relation primary key + +* The pk() method has to return the table primary key. The property of a primary +key is that it is a non-null unique record identifier. When pk() is invoked on +a Relation object, this base definition is applied to construct the object +primary key. + +To find a unique set of fields that makes a good primary key for a Relation +object, the following, simple algorithm is used: + + . . + . for each table . + . if the table is not referenced by another table that . + . is in the current relation . + . do . + . append the current table's primary key fields to . + . the Relation primary key fields . + . end-do . + . end-if . + . end-for . + . . + +This algorithm selects all the tables that represent the "many" in one-to-many +relations, and for all these tables add a list of fields which ensure a record +uniqueness. + +=head2 Foreign keys management + +* When invoked on a GT::SQL::Table object, the fk() method returns a hash which +has the following general structure: + + { + target_table_1 => { + source_col_1 => target_col_1, + source_col_2 => target_col_2 + }, + target_table_2 => { + source_col_1 => target_col_1 + } + } + +The GT::SQL::Relation module returns a hash which has the same structure. The +only difference is that it does not returns the external references which are +managed internally. + +This is done for two reasons: As one field is removed from a Relation table, it +would not have been very logical to return a structure that point to +non-existent fields. + +Moreover, these internal references from the "Relation" point of view have +nothing to do with the external world and thus should not be shown. + +(i.e. EMPLOYEE.COMPANY_ID |===> COMPANY.ID would not count in our example) + +=head2 Inserting data + +The interface for inserting data in a Relation is the same as the one that is +being used for Table. However, because rows are being inserted in a relation +one-to-many, things internally work a bit differently. + +The Relation insert() method takes an optional argument, which can be +'complete' or 'abort' (default being complete). + +insert() splits the relation columns into separate records that can be inserted +in a single table. However, some of the records may exist already! + +for example, if we perform: + + $sql = shift; # our GT::SQL object + $rel = $sql->table(qw/EMPLOYEE COMPANY/); + $rel->insert({ + 'EMPLOYEE.NAME' => $your_name, + 'EMPLOYEE.SALARY' => $big_buck, + 'COMPANY.NAME' => "Gossamer Threads" + }); + +Obviously the company "Gossamer Threads" already exists, but you were not in +the "EMPLOYEE" table. Thus, when 'complete' is specified (it is the default +option), the program will not complain if a record to insert already exists but +just warns and continue the insertion work. + +In other words, Gossamer Threads exists already and it will not be inserted +twice, but the employee will still be inserted and will belong to this company. + +On the other hand, if you specify "abort", then no data is inserted if a +record that has to be inserted would trigger an error in GT::SQL::Table. + +This feature can be useful if you want to insert a relation record assuming +that none of the entities that you specify should exist. + +=head2 Deleting data + +Deleting data from a Relation object works using the following pattern: + + . . + . for each row that matches the delete condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . delete the record . + . end-do . + . . + . for each table that is being referenced by another . + . table in the current relation object . + . do . + . delete the record unless there exists . + . some "referencing" data. . + . end-do . + . . + +As I feel that this explanation is probably very confusing, let us see how it +works using our classical example (The salary column has been removed). + + .-------------------------------------------------------------. + | EMPLOYEE.ID | COMPANY_ID | EMPLOYEE.NAME | COMPANY.NAME | + `-------------------------------------------------------------' + | 1 | 1 | Alex | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 2 | 1 | Scott | Gossamer Threads | + |-------------|------------|---------------|------------------| + | 3 | 1 | Aki | Gossamer Threads | + `-------------------------------------------------------------' + +Now let us say that we do the following: + + # remove all the crazy geeks + $relation->delete({ 'EMPLOYEE.NAME' => 'Scott' }); + +This will remove "Scott" from the EMPLOYEE table, but of course +Gossamer Threads will not be deleted because there still exists Alex and Aki +that would reference it. + +Now if we do: + + $relation->delete({ 'COMPANY.NAME' => 'Gossamer Threads' }); + +or even + + my $condition = new GT::SQL::Condition; + $condition->add(qw/EMPLOYEE.NAME LIKE %/); + $relation->delete($condition); + +Then we have generated a condition that matches all the employees, this means +that when the last record will be deleted, then the company Gossamer Threads +will have no more employees and therefore will be deleted. + +(Yeah, well, this is for the purpose of this example, of course this will never +happen in real life :) ) + +=head2 Updating records + +Currently, there exists a limitation on updating records in a Relation, which +is that only the records that represent the "many" part of the Relation are +updated. + +The way it proceeds to perform the update is pretty simple: + + . . + . for each row that matches the update condition . + . do . + . split the row in table-based records . + . for each table that contains foreing keys from the . + . current relation object . + . do . + . update the record . + . end-do . + . . + +That means that this will work: + + # SALARY being a property of EMPLOYEE, it will be updated + # because EMPLOYEE references COMPANY and therefore is a + # "many" + $relation->update({ SALARY => $big_bill }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + + # nope, you cannot use Relation to update the COMPANY table that + # way, this will not do anything. + $relation->update({ 'COMPANY.NAME' => 'New_Name' }, + { 'COMPANY.NAME' => 'Gossamer Threads' }); + +Who would like to change such a great name anyway ? + +=head2 Selecting Records + +Select behaves exactly like L select. The only difference is +the ability to specify LEFT JOINs. For instance, if you want to see a list of +Employees who don't belong to a company, you can do: + + my $relation = $DB->table('Employees', 'Company'); + my $cond = GT::SQL::Condition->new('Company.ID', 'IS', \'NULL'); + my $sth = $relation->select('left_join', $cond); + +The order of tables specified in the relation constructor is important! + +In selecting columns, calling functions utilizing fully qualified column names +will cause GT::SQL::Relation to fail. Simply turn the values into references +like below. + + my $sth = $relation->select("MIN(Company.ID)"); # will fail + + my $sth = $relation->select(\"MIN(Company.ID)"); # will work + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search.pm new file mode 100644 index 0000000..f2e0d86 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search.pm @@ -0,0 +1,585 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# highlevel class for searching, works with GT::SQL::Indexer +# + +package GT::SQL::Search; +#-------------------------------------------------------------------------------- + +# pragmas +use strict; +use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/; + +# includes +use GT::Base; +use GT::AutoLoader; + +# variables +$VERSION = sprintf "%d.%03d", q$Revision: 1.62 $ =~ /(\d+)\.(\d+)/; +@ISA = qw(GT::Base); +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + UNKNOWNDRIVER => 'Unknown driver requested: %s', + NOTABLE => 'Cannot find reference to table object' +}; + +sub load_search { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Search'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Search"; + return $pkg->load(@_); +} + +sub load_indexer { +#-------------------------------------------------------------------------------- +# checks if there is driver for this current database and if so, loads that +# instead (since it would be faster) +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + $opts->{mode} = 'Indexer'; + my $driver = $class->load_driver( $opts ) or return; + my $pkg = "GT::SQL::Search::${driver}::Indexer"; + + return $pkg->load(@_); +} + +sub driver_ok { +#-------------------------------------------------------------------------------- +# checks to see if a particular driver is allowed on this system +# + my $class = shift; + my $driver = uc shift or return; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $mode = $opts->{mode} || 'Indexer'; + my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' ); + my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode; + + eval { require "GT/SQL/Search/$driver/$mode.pm" }; + $@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver); + return $pkg->can('ok') ? $pkg->ok($tbl) : 1; +} + +sub load_driver { +#-------------------------------------------------------------------------------- +# Loads a driver into memory. +# + my $class = shift; + my $opts = ref $_[0] ? $_[0] : {@_}; + my $tbl = $opts->{table}; + my $mode = $opts->{mode} || 'Indexer'; + my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED'); + + require "GT/SQL/Search/$driver/$mode.pm"; + return $driver; +} + +sub available_drivers { +#-------------------------------------------------------------------------------- +# Returns a list of available drivers. +# + my $class = shift; + + (my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//; + opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!"); + my @arr; + for my $driver_name (readdir DHANDLE) { + next if $driver_name =~ y/a-z//; + next if $driver_name eq 'LUCENE'; + -f "$path/$driver_name/Search.pm" and -r _ or next; + -f "$path/$driver_name/Indexer.pm" and -r _ or next; + my $loaded = eval { + require "GT/SQL/Search/$driver_name/Search.pm"; + require "GT/SQL/Search/$driver_name/Indexer.pm"; + }; + push @arr, $driver_name if $loaded; + } + closedir DHANDLE; + return wantarray ? @arr : \@arr; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Search - internal driver for searching + +=head1 SYNOPSIS + +This implements the query string based searching scheme for GT::SQL. Driver +based, it is designed to take advantage of the different indexing schemes +available on different database engines. + +=head1 DESCRIPTION + +Instead of describing how Search.pm is interfaced* this will describe how a +driver should be structured and how a new driver can be implemented. + +* as it is never accessed directly by the programmer as it was designed to be +called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth + +=head2 Drivers + +A driver has two parts. The Indexer and the Search packages are the most +important. Howserver, for any driver in the search, there must exist a directory +with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES +for Postgres. Within each driver directory, The Indexer and Search portions of +the driver contains all the information required for initializing the database +table and searching the database. + +The Indexing package of the driver handles all the data that is manipulated in +the database and also the initializes and the database for indexing. + +The Search package handles the queries and retrieves results for the eventual +consumption by the calling program. + +Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base +and operate by overriding certain key functions. + +The next few sections will cover how to create a search driver, and assumes a +fair bit of familiarity with GT::SQL. + +=head2 Structure of an Indexing Driver + +The following is an absolutely simple skeleton driver that does nothing and but +called "CUSTOM". Found in the CUSTOM directory, this is the search package, and +would be call Search.pm in the GT/SQL/Search/CUSTOM library directory. + + package GT::SQL::Search::CUSTOM::Search; + #------------------------------------------ + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) }; + + # overrides would go here + + 1; + +For the indexer, another file, Indexer.pm would be found in the +GT/SQL/Search/CUSTOM directory. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::SQL::Search::Base; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + + # overrides would go here + + 1; + +The almost empty subs that immediately return with a value are functions that +can be overridden to do special tasks. More will be detailed later. + +The Driver has been split into two packages. The original package name, +GT::SQL::Search::Nothing, houses the Search package. +GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system. +"::Indexer" must be appended to the orginial search name for the indexer. + +Each of the override functions are triggered at points just before and after a +major event occurs in GT::SQL. Depending on the type of actions you require, you +pick and chose which events you'd like your driver to attach to. + +=head2 Structure of Indexing Driver + +The Indexer is responsible for creating all the indexes, maintaining them and +when the table is dropped, removing all the associated indexes. + +The following header must be defined for the Indexer. +GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from. + + package GT::SQL::Search::CUSTOM::Indexer; + #------------------------------------------ + + use strict; + use vars qw/ @ISA /; + use GT::Base; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +In addition to the header, the following function must be defined. +GT::SQL::Search::Driver::Indexer::load creates the new object and allows for +special preinitialization that must occur. You can also create another driver +silently (such as defaulting to INTERNAL after a version check fails). + + sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) }; + +Finally, there are the overrides. None of the override functions need be defined +in your driver. Any calls made to undefined methods will silently fallback to +the superclass driver's methods. When a method has been overridden, the function +must return a true value when it is successful, otherwise the action will fail +and an error generated. + +Whenever a object is created it will receive one property $self->{table} which +is the table that is being worked upon. This property is available in all the +method calls and is required for methods such as _create_table and +_drop_search_driver methods. + +When a table is first created or when a table is destroyed the following two +functions are called. They are not passed any special values, however, these are +all class methods and $self->{table} will be a reference to the current table in +use. + +This set of overrides are used by GT::SQL::Creator when the ::create method is +called. They are called just prior and then after the create table sql query has +been executed. + +=over 2 + +=item pre_create_table + +=item post_create_table + +These functions receive no special parameters. They will receive the data to the +table in the $self->{table} property. + +=back + +This next set of functions take place in GT::SQL::Editor. + +=over 2 + +=item drop_search_driver + +This method receives no special parameters but is responsible for removing all +indexes and "things" associated with the indexing schema. + +=item add_search_driver + +Receives no extra parameters. Creates all indexes and does all actions required +to initialize indexing scheme. + +=item pre_add_column + +=item post_add_column + +The previous two functions are called just before and after a new column is +added. + +pre_add_column accepts $name (of column), $col (hashref of column attributes). +The method will only be called if the column has a weight associated with it. +The function must return a non-zero value if successful. Note that the returned +value will be passed into the post_add_column so temporary values can be passed +through if required. + +post_add_column accepts $name (of column), $col (hashref of column attributes), +$results (of pre_add_column). This method is called just after the column has +been inserted into the database. + +=item pre_delete_column + +=item post_delete_column + +These previous functions are called just before and after the sql for a old +column is deleted. They must remove all objects and "things" associated with a +particular column's index. + +pre_delete_column accepts $name (of column), $col (hashref of column +attributes). The method will only be called if the column has a weight +associated with it. The function must return a non-zero value if successful. +Note that the returned value will be passed into the post_delete_column so +temporary values can be passed through if required. + +post_delete_column accepts $name (of column), $col (hashref of column +attributes), $results (of pre_add_column). This method is called just after the +column has been dropped from the database. + +=item pre_drop_table + +=item post_drop_table + +The two previous methods are used before and after the table is dropped. The +methods must remove any tables or "things" related to indexing from the table. + +pre_drop_table receives no arguments. It can find a copy of the current table +and columns associated in $self->{table}. + +post_drop_table receives one argument, which is the result of the +pre_drop_table. + +=back + +The following set of functions take place in GT::SQL::Table + +=over 2 + +=item pre_add_record + +=item post_add_record + +Called just before and after an insert occurs. These functions take the record +and indexes them as required. + +pre_add_record will receive one argument, $rec, hashref, which is the record +that will be inserted into the database. Table information can be found by +accessing $self->{table} Much like the other functions, on success the result +will be cached and fed into the post_add_record function. + +post_add_record receives $rec, a hashref to describing the new result, the $sth +of the insert query, and the result of the pre_add_record method. The result +from $sth->insert_id if there is a ai field will be the new unique primary key. + +=item pre_update_record + +=item post_update_record + +Intercepts the update request before and just after the sql query is executed. +This override has the potential of being rather messy. More than one record can +be modified in this action and the indexer must work a lot to ensure the +database is up to snuff. + +pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is +a hashref containing the new values that must be set, and $where_cond is a +GT::SQL::Condition object selecting records to update. The result once again, is +cached and if undef is considered an error. + +post_update_record takes the same parameters as pre_update_record, except one +extra paremeter, the result of pre_update_record. + +=item pre_delete_record + +=item post_delete_record + +Called just before and after the deletion request for records are called. + +pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object +telling which records to delete. The results of this method are passed to +post_delete_record. + +post_delete_record, has one addition parameter to pre_delete_record and like +most post_ methods, is the result of the pre_delete_record method. + +=item pre_delete_all_records + +=item post_delete_all_records + +These two functions are quite simple, but they are different from drop search +driver in that though the records are all dropped, the framework for all the +indexing is not dropped as well. + +Neither function is passed any special data, except for post_delete_all_records +which receives the rsults of the pre_delete_all_records method. + +=item reindex_all + +This function is sometimes called by the user to refresh the index. The +motivation for this, in the case of the INTERNAL driver, is sometimes due to +outside manipulation of the database tables, the index can become +non-representative of the data in the tables. This method is to force the +indexing system to fix errors that have passed. + +=item ok + +This function is called by GT::SQL::Search as a package method, +GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object +reference. What this function must do is to return a true or false value that +tells the search system if this driver can be used. The MYSQL driver has a good +example for this, it tests to ensure that the mysql database system version is +at least 3.23.23. + +=back + +=head2 Structure of a Search Driver + +The Searcher is responsible for only one thing, to return results from a query +search. You can override the parser, however, subclassing the following methods +will have full parsing for all things such as +/-, string parsing and substring +matching. + +The structures passed into the methods get a little complicated so beware! + +ALL the following functions receive two parameters, the first is a search +parameters detailing the words/phrases to search for, the second parameter is +the current result set of IDs => scores. + +There are two types of search parameters, one for words and the other for +phrases. The structure is a little messy so I'll detail them here. + +For words, the structure is like the following: + + $word_search = { + 'word' => { + substring => '1', # set to 1 if this is substring match + phrase => 0, # not a phrase + keyword => 1, # is a keyword + mode => '', # can also be must, cannot to mean +/- + }, + 'word2' => ... + } + +For phrases the structure will become: + + $phrase_search => { + 'phrase' => { + substring => undef # never required + phrase => [ + 'word1', + 'word2', + 'word3', + ... + ], # for searching by indiv word if required + keyword => 0, # not a keyword + mode => '' # can also be must, cannot + }, + 'phrase2' => ... + } + +Based on these structures, hopefully it will be easy enough to build whatever is +required to grab the appropriate records. + +Finally, the second item passed in will be a hash filled with ID => score values +of search results. They look something like this: + + $results = { + 1 => 56, + 2 => 31, + 4 => 6 + } + +It is important for all the methods to take the results and return the results, +as the result set will be daisychained down like a set to be operated on by +various searching schemes. + +At the end of the query, the results in this set will be sorted and returned to +the user as an sth. + +Operations on this set are preformed by the following five methods. + +=over 2 + +=item _query + +This method is called just after all the query string has been parsed and put +into their proper buckets. This method is overridden by the INTERNAL driver to +decide it wants to switch to the NONINDEX driver for better performance. + +Two parameters are passed in, ( $input, $buckets ). $input is a hash that +contains all the form/cgi parameters passed to the $tbl->query function and +$buckets is s the structure that is created after the query string is parsed. +You may also call $self->SUPER::_query( $input, $buckets ) to pass the request +along normally. + +You must return undef or an STH from this function. + +=item _union_query + +This method takes a $word_search and does a simple match query. If it finds +records with any of the words included, it will append the results to the list. +Passed in is the $results and it must return the altered results set. + +This method must also implement substring searching. + +=item _phrase_query + +Just like the union_query, however it searches based on phrases. + +=item _phrase_intersect_query + +This takes a $phrase_search and a $result as parameters. This method must look +to find results that are found within the current result set that have the +passed phrases as well. However, if there are no results found, this method can +look for more results. + +=item _intersect_query + +Takes two parameters, a $word_search, and $results. Just like the +_phrase_intersect query, if there are results already, tries to whittle away the +result set. If there are no results, tries to look for results that have all the +keywords in a record. + +This method must also implement substring searching. + +=item _disjoin_query + +Takes two parameters, a $word_search, and $results. This will look through the +result set and remove all matches to any of the keywords. + +This method must also implement substring searching. + +=item _phrase_disjoin_query + +Two parameters, $phrase_search and $results are passed to this method. This does +the exact same thing as _disjoin_query but it looks for phrases. + +=item query + +If you choose to override this method, you will have full control of the query. + +This method accepts a $CGI or a $HASH object and performs the following + + Options: + - paging + mh : max hits + nh : number hit (or page of hits) + sb : column to sort by (default is by score) + + - searching + ww : whole word + ma : 1 => OR match, 0 => AND match, undefined => QUERY + substring : search for substrings of words + bool : 'and' => and search, 'or' => or search, '' => regular query + query : the string of things to ask for + + - filtering + field_name : value # Find all rows with field_name = value + field_name : ">value" # Find all rows with field_name > value. + field_name : " value. + field_name-lt : value # Find all rows with field_name < value. + +The function must return a STH object. However, you may find useful the +GT::SQL::Search::STH object, which will automatically handle mh, nh, and +alternative sorting requests. All you will have to do is + + sub query { ... your code ... return $self->sth( $results ); } + +Where results is a hashref containing primarykeyvalue => scorevalues. + +=item alternate_driver_query + +There is no reason to override this method, however, if you would like to use +another driver's search instead of the current, this method will let you do so. + +Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name +of the driver you'd like to use and $input is the parameters passed to the +method. Returned is an $sth value (undef if an error has occurred). This method +was used in the INTERNAL driver to shunt to NONINDEXED if it found the search +would take too long. + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Common.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Common.pm new file mode 100644 index 0000000..30e4011 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Common.pm @@ -0,0 +1,82 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Common +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# +package GT::SQL::Search::Base::Common; + +use strict; +use Exporter; +use vars qw/ @ISA @EXPORT $STOPWORDS /; + + @ISA = qw( Exporter ); + @EXPORT = qw( &_tokenize &_check_word $STOPWORDS ); + + $STOPWORDS = { map { $_ => 1 } qw/ + of about or all several also she among since an some and such are than + as that at the be them because there been these between they both this + but those by to do toward during towards each upon either for from was + had were has what have when he where her which his while however with if + within in would into you your is it its many more most must on re it + test not above add am pm jan january feb february mar march apr april + may jun june jul july aug august sep sept september oct october nov + november dec december find & > < we http com www inc other + including + / }; + +sub _tokenize { +#-------------------------------------------------------------------------------- +# takes a strings and chops it up into little bits + my $self = shift; + my $text = shift; + my ( @words, $i, %rejected, $word, $code ); + +# split on any non-word (includes accents) characters + @words = split /[^\w\x80-\xFF\-]+/, lc $text; + $self->debug_dumper( "Words: ", \@words ) if ($self->{_debug}); + +# drop all words that are too small, etc. + $i = 0; + while ( $i <= $#words ) { + $word = $words[ $i ]; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + splice( @words, $i, 1 ); + $rejected{$word} = $self->{'rejections'}->{$code}; + } + else { + $i++; # Words ok. + } + } + $self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug}); + $self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug}); + + return ( \@words, \%rejected ); +} + +sub _check_word { +#-------------------------------------------------------------------------------- +# Returns an error code if it is an invalid word, otherwise returns nothing. +# + my $self = shift; + my $word = shift; + my $code; + if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or + (length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or + (length($word) > $self->{max_word_size} and $code = 'TOOBIG')) { + return $code; + } + return; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Indexer.pm new file mode 100644 index 0000000..1fed440 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Indexer.pm @@ -0,0 +1,78 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# +# + +package GT::SQL::Search::Base::Indexer; + + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/GT::Base GT::SQL::Search::Base::Common/; + $ATTRIBS = { + driver => undef, + stopwords => $STOPWORDS, + rejections => { + STOPWORD => "is a stopword", + TOOSMALL => "is too small a word", + TOOBIG => "is too big a word" + }, + table => '', + init => 0, + debug => 0, + min_word_size => 3, + max_word_size => 50, + }; + +sub drop_search_driver { 1 } +sub add_search_driver { 1 } + +# found in GT::SQL::Creator +sub pre_create_table { 1 } +sub post_create_table { 1 } + +# GT::SQL::Editor +sub pre_add_column { 1 } +sub post_add_column { 1 } + +sub pre_delete_column { 1 } +sub post_delete_column { 1 } + +sub pre_drop_table { 1 } +sub post_drop_table { 1 } + +# GT::SQL::Table +sub pre_add_record { 1 } +sub post_add_record { 1 } + +sub pre_update_record { 1 } +sub post_update_record { 1 } + +sub pre_delete_record { 1 } +sub post_delete_record { 1 } + +sub pre_delete_all_records { 1 } +sub post_delete_all_records { 1 } + +sub driver_ok { 1 } + +sub reindex_all { 1 } + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/STH.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/STH.pm new file mode 100644 index 0000000..53a051d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/STH.pm @@ -0,0 +1,287 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::STH +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::STH; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /; + use GT::Base; + + @ISA = ('GT::Base'); + $ATTRIBS = { + '_debug' => 0, + 'sth' => undef, + 'results' => {}, + 'db' => undef, + 'table' => undef, + 'index' => 0, + 'order' => [], + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'nh' => 0, + 'mh' => 0 + }; + $ERROR_MESSAGE = 'GT::SQL'; + $ERRORS = { + BADSB => 'Invalid character found in so: "%s"', + }; + +sub init { +#-------------------------------------------------------------------------------- + my $self = shift; + +# setup the options + $self->set(@_); + +# correct a few of the values + --$self->{nh} if $self->{nh}; + + my $sth; + my $results = $self->{results}; + $self->{rows} = scalar( $results ? keys %{$results} : 0 ); + +# if we have asked to have sorting by another column (non score), create the part of the query that handles taht + $self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug}); + my $sb; + +# clean up the sort by columns. + unless ($self->{'score_sort'}) { + $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so}); + } + +# setup the max hits and the offsets + $self->{index} = $self->{nh} * $self->{mh} || 0; + $self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned. + + if ( $self->{max_index} > $self->{rows} ) { + $self->{max_index} = $self->{rows}; + $self->{rows} = $self->{rows} - $self->{index}; + $self->{rows} < 0 ? $self->{rows} = 0 : 0; + } + + else { + $self->{rows} = $self->{mh}; + } + +# if we are sorting by another column, handle that + if ( $sb and (keys %{$self->{results}})) { + my ( $table, $pk ) = $self->_table_info(); + my ( $query, $where, $st, $limit ); + + $where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')'; + $self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!; + $query = qq! + SELECT $pk + FROM $table + WHERE $where + $sb + $limit + !; + $self->debug( "Row fetch query: $query" ) if ($self->{_debug}); + $sth = $self->{table}->{driver}->prepare( $query ); + $sth->execute(); + +# fix the counts + $self->{index} = 0; + $self->{max_hits} = $self->{rows}; + +# now return them + my $order = $sth->fetchall_arrayref(); + $sth->finish(); + + $self->{'order'} = [ map { $_->[0] } @{$order} ]; + } + else { + $self->{'order'} = [ sort { + ( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 ) + } keys %{$results} ]; + $self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug}); + } + +} + +sub cache_results { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my ($sth, @records, $i, %horder, @order, $in_list); + my $table = $self->{table}; + my $tname = $table->name(); + my ($pk) = $self->{table}->pk; + + use GT::SQL::Condition; + +# we know what we're doing here so shut off warns (complains about uninit'd values in range +# if thee aren't enough elements in the order array) + my $w = $^W; $^W = 0; + @order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return []; + $^W = $w; + + $i = 0; %horder = ( map { ( $_ => $i++) } @order ); + $in_list = join ( ",", @order ); + my $query = qq| + SELECT * + FROM + $tname + WHERE + $pk IN($in_list) + |; + +# the following is left commented out as... +# if $tbl->select is used $table->hits() will not +# return an accurate count of the number of all the hits. instead, will return +# a value up to mh. $tbl->hits() is important because the value is used +# in toolbar calculations +# +# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) ); + $sth = $table->do_query( $query ); + + while ( my $href = $sth->fetchrow_hashref() ) { + $records[$horder{$href->{$pk}}] = \%$href + } + + return \@records; + +} + +sub fetchrow_array { +#-------------------------------------------------------------------------------- + return @{ $_[0]->fetchrow_arrayref() || [] }; +} + +sub fetchrow_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + my $records = $self->{cache} ||= $self->cache_results; + my $href = shift @$records or return; + return $self->_hash_to_array($href); +} + +sub fetchrow_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + + my $results = $self->{'results'}; + my $records = $self->{cache} ||= $self->cache_results; + my $table = $self->{table}; + my ($pk) = $self->{table}->pk; + + my $href = shift @$records or return; + + $href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} ); + + return $href; + +} + +sub fetchall_hashref { +#-------------------------------------------------------------------------------- + my $self = shift; + my @results; + while (my $res = $self->fetchrow_hashref) { + push @results, $res; + } + return \@results; +} + +sub fetchall_list { +#-------------------------------------------------------------------------------- + return { map { @$_ } @{shift->fetchall_arrayref} } +} + +sub fetchall_arrayref { +#-------------------------------------------------------------------------------- + my $self = shift; + + $self->{order} or return []; + my $results = $self->{results}; + my ($pk) = $self->{table}->pk; + my $scol = $self->{score_col}; + + + if (!$self->{allref_cache}) { + $self->{allref_cache} ||= $self->cache_results; + + for my $i ( 0 .. $#{$self->{allref_cache}} ) { + my $element = $self->{allref_cache}->[$i]; + if ( $_[0] eq 'HASH' ) { + $element->{$scol} = $results->{$element->{$pk}}; + } + else { + $element->{$scol} = $self->_hash_to_array( $element->{$scol} ); + } + }; + } + + my $records = $self->{allref_cache}; + + return $records; +} + +sub score { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{score}; +} + +sub _hash_to_array { +#-------------------------------------------------------------------------------- + my $self = shift; + my $href = shift or return; + + my $results = $self->{'results'}; + my $table = $self->{table}; + my $cols = $table->cols(); + my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] ); + my ($pk) = $self->{table}->pk; + my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ]; + + return $aref; +} + +sub rows { +#-------------------------------------------------------------------------------- + my $self = shift; + return $self->{rows}; +} + +sub _table_info { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my ($pk) = $self->{table}->pk; + return ( $table, $pk ); +} + +sub DESTROY { +#-------------------------------------------------------------------------------- + my $self = shift; + $self->{'sth'} and $self->{'sth'}->finish(); +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Search.pm new file mode 100644 index 0000000..f16d559 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/Base/Search.pm @@ -0,0 +1,572 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::Base +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Base classes upon which all search drivers are based +# + +package GT::SQL::Search::Base::Search; + + + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::Base; + use GT::SQL::Search::Base::Common; + @ISA = qw( GT::Base GT::SQL::Search::Base::Common); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/; + @ISA = qw/ GT::Base /; + + $ATTRIBS = { + 'stopwords' => $STOPWORDS, + 'mh' => 25, + 'nh' => 1, + 'ww' => undef, + 'ma' => undef, + 'bool' => undef, + 'substring' => 0, + 'query' => '', + 'sb' => 'score', + 'so' => '', + 'score_col' => 'SCORE', + 'score_sort'=> 0, + 'debug' => 0, + '_debug' => 0, + +# query related + 'db' => undef, + 'table' => undef, + 'filter' => undef, + 'callback' => undef, + +# strict matching of indexed words, accents on words do count + 'sm' => 0, + 'min_word_size' => 3, + 'max_word_size' => 50, + }; + +sub init { +#-------------------------------------------------------------------------------- +# Initialises the Search object +# + my $self = shift; + my $input = $self->common_param(@_); + + $self->set($input); + +# now handle filters..., + my $tbl = $self->{table}; + my $cols = $tbl->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + exists $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if ( keys %filters ) { + $self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} ); + $self->filter(\%filters); + } + + $self->{table}->connect; +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query..., + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{'rejected_keywords'} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = &_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + return $self->_query($input, $buckets); +} + +sub _query { +#-------------------------------------------------------------------------------- + my ( $self, $input, $buckets ) = @_; + +# now handle the separate possibilities + my $results = {}; + +# query can have phrases + $results = $self->_phrase_query( $buckets->{phrases}, $results ); + $self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query have keywords + $results = $self->_union_query( $buckets->{keywords}, $results ); + $self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have phrases + $results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results ); + $self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query must have keywords + $results = $self->_intersect_query( $buckets->{keywords_must}, $results ); + $self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have keywords + $results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results ); + $self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# query cannot have phrases + $results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results); + $self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug}); + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + $cols->{$tmp} ? ($_ => $input->{$_}) : () + } keys %{$input}; + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $results = $self->filter(\%filters, $results); + } + elsif ($self->{filter}) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $results = $self->_filter_query( $self->{filter}, $results ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll dothat here + $self->{filter} = undef; + +# now run through a callback function if needed. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + $self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + } + +# so how many hits did we get? + $self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) ); + +# and now create a search sth object to handle all this + return $self->sth( $results ); +} + +sub sth { +#-------------------------------------------------------------------------------- + my $self = shift; + my $results = shift; + + require GT::SQL::Search::Base::STH; + my $sth = GT::SQL::Search::STH->new( + 'results' => $results, + 'db' => $self->{table}->{driver}, +# pass the following attributes down to the STH handler + map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /) + ); + + return $sth; +} + +sub rows { +#-------------------------------------------------------------------------------- +# after a query is run, returns the number of rows + my $self = shift; + return $self->{rows} || 0; +} + +sub _add_filters { +#-------------------------------------------------------------------------------- +# creates the filter object + my $self = shift; + my $filter; + +# find out how we're calling the parameters + if ( ref $_[0] eq 'GT::SQL::Condition' ) { + $filter = shift; + } + elsif ( ref $_[0] eq 'HASH' ) { + + +# setup the query condition using the build_query condition method +# build the condition object + my %opts = %{ shift() || {} }; + delete $opts{query}; + + $filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} ); + + } + else { + return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter"); + } + +# Use ref, as someone can pass in filter => 1 and mess things up. + + ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter); + $self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug}); + + return $self->{filter}; + +} + +sub _preset_options { +#-------------------------------------------------------------------------------- +# sets up word parameters + my $self = shift; + my $query = shift or return; + my $input = shift or return $query; + +# whole word searching + if ( defined $input->{'ww'} or defined $self->{'ww'}) { + if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; } + } + } + +# substring searching + if ( defined $input->{'substring'} or defined $self->{'substring'}) { + if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) { + for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; } + } + } + + if ( defined $input->{'ma'} or defined $self->{'ma'} ) { +# each keyword must be included + if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } +# each word can be included but is not necessary + else { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + +# some more and or searches, only if user hasn't put +word -word + if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { + next if $query->{$_}->{mode} eq 'cannot'; + $query->{$_}->{mode} = 'must'; + } + } + } + elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) { + unless ($input->{query} =~ /(?:^|\s)[+-]\w/) { + for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; } + } + } + + return $query; +} + +sub _phrase_query { $_[1] } +sub _union_query { $_[1] } +sub _phrase_intersect_query { $_[1] } +sub _intersect_query { $_[1] } +sub _disjoin_query { $_[1] } +sub _phrase_disjoin_query { $_[1] } + +sub filter { +#-------------------------------------------------------------------------------- +# adds a filter +# + my $self = shift; + +# add filters.., + my $filters = $self->_add_filters( shift ); + my $results = shift; + +# see if we need to execute a search, otherwise just return the current filterset + defined $results or return $results; + +# start doing the filter stuff + return $self->_filter_query( $filters, $results ); +} + +sub _parse_query_string { +#------------------------------------------------------------ +# from Mastering Regular Expressions altered a fair bit +# takes a space delimited string and breaks it up. +# + my $self = shift; + my $text = shift; + + my %words = (); + my %reject = (); + my %mode = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# work on the individual elements + my @new = (); + while ( $text =~ m{ + # the first part groups the phrase inside the quotes. + # see explanation of this pattern in MRE + ([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ? + | (\+?[\w\x80-\xFF\-\*]+),? + | ' ' + }gx ) { + + my $match = lc $+; + +# strip out buffering spaces + $match =~ s/^\s+//; $match =~ s/\s+$//; + +# don't bother trying if there is nothing there + next unless $match; + +# find out the searching mode + my ($mode, $substring, $phrase); + if (my $m = $mode{substr($match,0,1)}) { + $match = substr($match,1); + $mode = $m; + } + +# do we need to substring match? + if ( substr( $match, -1, 1 ) eq "*" ) { + $match = substr($match,0,length($match)-1); + $substring = 1; + } + +# find out if we're dealing with a phrase + if ( substr($match,0,1) eq '"' ) { + $self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug}); + + $match = substr($match,1); + +# however, we want to make sure it's a phrase and not something else + my ( $word_list, $rejected ) = $self->_tokenize( $match ); + $self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug}); + $self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug}); + my $word_count = @$word_list; + + if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase + elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase + } + +# make sure we can use this word + if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) { + $reject{ $match } = $code; + next; + } + +# now, see if we should toss this word + $words{$match} = { + mode => $mode, + phrase => $phrase, + substring => $substring, + keyword => not $phrase, + }; + } + +# words is a hashref of: +# { +# word => { +# paramaters => 'values' +# }, +# word1 => { +# ... +# }, +# ... +# } +# + return( \%words, \%reject ); + +} + + +sub _filter_query { +#-------------------------------------------------------------------------------- +# get the results from the filter +# + my $self = shift; + my $filters = shift; + my $results = shift or return {}; + keys %{$results} or return $results; + + my $table = $self->{table}; + my $tname = $table->name(); + +# setup the where clause + my $where = $filters->sql() or return $results; + my ($pk) = $table->pk; + $where .= qq! AND $pk IN (! . join(',', keys %$results) . ')'; + +# now do the filter + my $query = qq! + SELECT $pk + FROM + $tname + WHERE + $where + !; + $self->debug( "Filter Query: $query" ) if ($self->{_debug}); + my $sth = $self->{table}->{driver}->prepare($query); + $sth->execute(); + +# get all the results + my $aref = $sth->fetchall_arrayref; + return { + map { + $_->[0] => $results->{$_->[0]} + } @$aref + }; +} + +sub _create_buckets { +#------------------------------------------------------------ +# takes the output from _parse_query_string and creates a +# bucket hash of all the different types of searching +# possible + my $query = shift or return; + + my %buckets; + +# put each word in the appropriate hash bucket + foreach my $parameter ( keys %{$query} ) { + + my $word_data = $query->{$parameter}; + +# the following is slower, however, done that way to be syntatically legible + if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) { + $buckets{"phrases_$1"}->{$parameter} = $word_data; + } + elsif ( $word_data->{'phrase'} ) { + $buckets{'phrases'}->{$parameter} = $word_data; + } + elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) { + $buckets{"keywords_$1"}->{$parameter} = $word_data; + } + else { + $buckets{'keywords'}->{$parameter} = $word_data; + } + + } + + return \%buckets; +} + +sub alternate_driver_query { +#-------------------------------------------------------------------------------- + my ( $self, $drivername, $input ) = @_; + + $drivername = uc $drivername; + require GT::SQL::Search; + my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername }); + my $sth = $driver->query( $input ); + foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; } + return $sth; + +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + +# Remove score attribute, used only for internal indexes. + $sb =~ s/^\s*score\b//; + $sb =~ s/,?\s*\bscore\b//; + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +sub debug_dumper { +#-------------------------------------------------------------------------------- +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug}); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Indexer.pm new file mode 100644 index 0000000..f8d9293 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Indexer.pm @@ -0,0 +1,411 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::INTERNAL::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::INTERNAL::Indexer; + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Indexer->new(@_) +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $table = $self->{table}->name; + my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List"); + my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List"); + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $name = $self->{table}->name; + +# first create the table that handles the words. + my $creator = $self->{table}->creator ( $name . "_Word_List" ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Word => { + pos => 2, + type => 'varchar', + not_null=> 1, + size => '50' + }, + Frequency => { + pos => 3, + type => 'int', + not_null=> 1 + } + ); + $creator->pk('Word_ID'); + $creator->ai('Word_ID'); + $creator->unique({ $name . "_wordndx" => ['Word'] }); + $creator->create('force') or return; + +# now create the handler for scores + $creator = $self->{table}->creator( $name . '_Score_List' ); + $creator->cols( + Word_ID => { + pos => 1, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Item_ID => { + pos => 2, + type => 'int', + not_null => 1, + unsigned => 1 + }, + Score => { + pos => 3, + type => 'int', + not_null => 1 + }, + Word_Pos => { + pos => 4, + type => 'int', + not_null => 1 + } + ); + $creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] }); + $creator->create('force') or return; + return 1; + +} + +sub post_create_table { +# ------------------------------------------------------------------------------ +# creates the index tables.. +# + return $_[0]->add_search_driver(@_); +} + +sub post_drop_table { +# ------------------------------------------------------- +# Remove the index tables. +# + return $_[0]->drop_search_driver(@_); +} + +sub init_queries { +# ------------------------------------------------------- +# Pre-load all our queries. +# + my $self = shift; + my $queries = shift; + + my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL'); + my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table_name . '_Word_List'; + my $seq = $wtable . '_seq'; + my $stable = $table_name . '_Score_List'; + + my %ai_queries = ( + ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)", + ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)", + ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)" + ); + my %queries = ( + upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?", + sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?", + sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?", + del_word => "DELETE FROM $wtable WHERE Word_ID = ?", + mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?", + ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)", + item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID", + scr_del => "DELETE FROM $stable WHERE Item_ID = ?", + dump_word => "DELETE FROM $wtable", + dump_scor => "DELETE FROM $stable" + ); + my $type = uc $self->{table}->{connect}->{driver}; + $self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"}); + +# check to see if the table exist + $self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + $self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error); + + + if ($type eq 'MYSQL') { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } + else { + foreach my $query (keys %queries) { + $self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error); + } + } +} + +sub post_add_record { +# ------------------------------------------------------- +# indexes a single record + my ($self, $rec, $insert_sth ) = @_; + +# Only continue if we have weights and a primary key. + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk}; + my $index = 0; + + $self->{init} or $self->init_queries; + +# Go through each column and index it. + foreach my $column ( keys %weights ) { + my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + my $weight = $weights{$column}; + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + + return 1; +} + +sub reindex_all { +# ------------------------------------------------------- + my $self = shift; + my $table = shift; + my $opts = shift; + my $tick = $opts->{tick} || 0; + my $max = $opts->{max} || 5000; + + my %weights = $self->{table}->_weight_cols() or return; + my @weight_list = keys %weights; + my @weight_arr = map { $weights{$_} } @weight_list; + my ($pk) = $self->{table}->pk(); + my $index = 0; + my $word_id = 1; + $self->{init} or $self->init_queries; + +# first nuke the current index + $self->dump_index(); + +# Go through the table and index each field. + my $iterations = 1; + my $count = 0; + + while (1) { + if ($max) { + my $offset = ($iterations-1) * $max; + $table->select_options ( "LIMIT $offset,$max"); + } + my $cond = $opts->{cond} || {}; + my $sth = $table->select($cond, [ $pk, @weight_list] ); + my $done = 1; + + while ( my $arrayref = $sth->fetchrow_arrayref() ) { +# the primary key value + my $i = 0; + my $item_id = $arrayref->[($i++)]; + $index = 0; + $done = 0; + +# start going through the record data + foreach my $weight ( @weight_arr ) { + my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] ); + $word_list or next; + +# Build a hash of word => frequency. + my %words; + foreach my $word (@{$word_list}) { + $words{$word}++; + } + +# Add the words in, or update frequency. + my %word_ids = (); + while (my ($word, $freq) = each %words) { + $self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq + if ($word_r) { + $word_r->[2] += $freq; + $word_ids{$word} = $word_r->[0]; + $self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $word_ids{$word} = $self->{ins_word}->insert_id(); + } + } +# now that we have the word ids, insert each of the word-points + foreach my $word ( @{$word_list} ) { + $self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + $index++; + } + if ($tick) { + $count++; + $count % $tick or (print "$count "); + $count % ($tick*10) or (print "\n"); + } + } + return if ($done); + $iterations++; + return if (! $max); + } +} + +sub pre_delete_record { +# ------------------------------------------------------- +# Delete a records index values. +# + my $self = shift; + my $where = shift; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + my ($pk) = $tbl->pk(); + my $q = $tbl->select( $where, [ $pk ] ); + + while ( my $aref = $q->fetchrow_arrayref() ) { + my $item_id = $aref->[0] or next; + my @weight_list = keys %weights; + my $index = 0; + $self->{init} or $self->init_queries; + + # Get a frequency count for each word + $self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + + # Now go through and either decrement the freq, or remove the entry. + while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) { + $self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug}); + if (my $freq = $self->{sel_freq}->fetchrow_arrayref) { + if ($freq->[0] == $frequency) { + $self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + else { + $self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + } + } + # Remove the listings from the scores table. + $self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr); + } + return 1; +} + +sub post_update_record { +# ------------------------------------------------------- + my ( $self, $set_cond, $where_cond, $tmp ) = @_; + +# delete the previous record + $self->pre_delete_record( $where_cond ) or return; +# +# the new record + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my $q = $tbl->select( $where_cond ); + while ( my $href = $q->fetchrow_hashref() ) { + $self->post_add_record( $href ); + } + + return 1; + +} + +sub reindex_record { +# ------------------------------------------------------- +# reindexes a record. basically deletes all associated records from current db abnd does an index. +# it's safe to use this + my $self = shift; + my $rec = shift; + + $self->delete_record($rec); + $self->index_record($rec); +} + +sub dump_index { +# ------------------------------------------------------- + my $self = shift; + $self->{init} or $self->init_queries; + + $self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); + $self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr); +} + + +sub debug_dumper { +# ------------------------------------------------------------------------------ +# calls debug but also dumps all the messages + my $self = shift; + my $message = shift; + my $level = ref $_[0] ? 1 : shift; + + if ( $self->{_debug} >= $level ) { + require GT::Dumper; + $self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )); + } +} + +sub DESTROY { +# ------------------------------------------------------------------------------ +# Calls finish on init queries. +# + my $self = shift; + return unless ($self->{init}); + $self->{upd_word}->finish; +# $self->{ins_word}->finish; will get finished automatically + $self->{sel_word}->finish; + $self->{sel_freq}->finish; + $self->{del_word}->finish; + $self->{mod_word}->finish; + $self->{ins_scor}->finish; + $self->{item_cnt}->finish; + $self->{scr_del}->finish; + $self->{dump_word}->finish; + $self->{dump_scor}->finish; + $self->{init} = 0; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Search.pm new file mode 100644 index 0000000..dd36edd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/INTERNAL/Search.pm @@ -0,0 +1,604 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Indexer +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to make changes to tables and create tables. +# + +package GT::SQL::Search::INTERNAL::Search; + +# ------------------------------------------------------------------------------ + use strict; + use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# the max number of links that can be handled by UNION before it should simply +# shunt the searching pipe to NONINDEXED system + 'union_shunt_threshold' => '5000', + 'phrase_shunt_threshold' => '1000', + }; + + +################################################################################ +# Internal functions +################################################################################ + +sub load { + shift; + return GT::SQL::Search::INTERNAL::Search->new(@_) +} + +sub _query { +# ------------------------------------------------------------------------------ +# this just checks to ensure that the words are not all search keywords +# + my ( $self, $input, $buckets ) = @_; + +# calculate wordids and frequencies + foreach ( keys %$buckets ) { + $buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) ); + } + +# the following is a bit tricky and will be replaced however, if the number +# of results from a union is more than the maximum shunt value, it will +# simply do a nonindexed query + if ( $buckets->{keywords} ) { + my $rec = _count_frequencies( $buckets->{keywords} ); + my $count = 0; + foreach ( values %$rec ) { $count += $_; } + if ($count > $self->{union_shunt_threshold}) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + + +# Now test the phrases. Just due to how the phrase searching works, the queries +# can grow in size extremely rapidly, and slowdown the search. So the limit for +# phrase searching is separate as it requires a different cutoff value than +# the keyword search which is usually much lower! + if ($buckets->{phrases}) { + foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + if ($buckets->{phrases_must}) { + foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) { + my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} ); + my ( $count ) = sort values %$rec; # Get smallest frequency. + if ( $count > $self->{phrase_shunt_threshold} ) { + $self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug}); + return $self->alternate_driver_query( 'NONINDEXED', $input ); + } + } + } + return $self->SUPER::_query( $input, $buckets ); +} + +sub _count_frequencies { +# ------------------------------------------------------------------------------ + my $word_info = shift; + my $rec = {}; + foreach my $word ( keys %$word_info ) { + my $freq = 0; + foreach ( values %{$word_info->{$word}->{word_info}} ) { + $freq += $_; + } + $rec->{$word} = $freq; + } + + return $rec; +} + +sub _table_names { +# ------------------------------------------------------------------------------ +# return the table names +# + my $self = shift; + my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL'); + my $wtable = $table . '_Word_List'; + my $stable = $table . '_Score_List'; + + return ( $table, $wtable, $stable); +} + +sub _word_infos { +# ------------------------------------------------------------------------------ +# get the word ids and frequencies +# + my $self = shift; + my $word_infos = shift; + + my $rec = {}; + + foreach my $word ( keys %$word_infos ) { + my $wi = $word_infos->{$word}->{word_info}; + $rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ]; + } + + return $rec; + +} + +sub _union_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + my ( $query, $where, $db, $word_infos ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return $results; + + return $results unless (keys %{$word_infos}); + + $self->debug_dumper( "Getting words: ", $words) if ($self->{_debug}); + +# build the where clause + my @word_ids; + foreach my $word_synonym_list ( values %$word_infos ) { + next unless ( $word_synonym_list ); + foreach my $word_id ( @{$word_synonym_list }) { + next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference + push @word_ids, $word_id->[0]; # we need to shed the word quantities + } + } + + return $results unless ( @word_ids ); + $where = 'Word_ID IN(' . join(",", @word_ids) . ")"; + +# build the query + $query = qq! + SELECT Item_ID, SUM(Score) + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + + $self->debug( "Union Query: $query" ) if ($self->{_debug}); + +# prepare the query + my $sth = $db->prepare( $query ) or return; + $sth->execute() or return; + +# get the results + my %word_infos = $sth->fetchall_list; + +# merge the current result set into found + foreach my $item ( keys %{$results} ) { + $word_infos{$item} += $results->{$item}; + }; + + return \%word_infos; +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ +# Takes a list of words and gets all words that match all the keywords +# returns { itemid -> score } of hits that match +# + my $self = shift; + my $words = shift; + my $results = shift || {}; + + $words or return $results; + keys %{$words} or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + +# have we left any of our words out? + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $words ) or return {}; + if ( keys %{$word_infos} < keys %{$words} ) { + return {}; + } + + $self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + + $word_hits->{$word} = $total_freq or return; + + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits}; + + $self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug}); + +# find out how we're going to handle the searching, if the first elements + +################################################################################ +### The following part is for smaller intersect subsets +################################################################################ + my $intersect = $results; + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$intersect} ) { + $where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID, SUM(Score) AS Score + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug( "Intersect Query: $query" ) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + + $self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug}); + +# go through all the matches and intersect them + my %tmp = (); + foreach my $row ( @{$matches} ) { + my ( $itemid, $score ) = @{$row}; + $intersect->{$itemid} ||= 0; + $tmp{ $itemid } = $intersect->{$itemid} + $score; + } + +# inform the system of that development + %tmp or return; + $intersect = \%tmp; + } + + return $intersect; +} + +sub _disjoin_query { +#------------------------------------------------------------ + my $self = shift; + my $words = shift; + my $results = shift || {}; + $words or return $results; + + my ( $query, $where, $db, $word_infos, $word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + + $db = $self->{table}->{driver} or return $results; + +# have we left any of our words out? + $word_infos = $self->_word_infos( $words ) or return $results; +# if ( keys %{$word_infos} < keys %{$words} ) { +# return $results; +# } + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + my $total_freq = 0; + foreach my $word_synonyms ( $word_infos->{$word} ) { + $total_freq += ( $word_synonyms->[0] || 0 ); + } +# if the value is null this mean there is actually no results, whoops! + $total_freq and $word_hits->{$word} = $total_freq; + } + +# so now, sort out the words from lowest frequency to highest frequency + my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits}; + $self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller disjoin presets +################################################################################ + foreach my $word ( @search_order ) { + +# setup the where clause to get all the words associated + my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")"; + +# setup the intersect for the previous if required. for iterative intersecting + if ( keys %{$results} ) { + $where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")"; + } + +# make the database engine work a little bit + $query = qq! + SELECT Item_ID + FROM $stable + WHERE + $where + GROUP BY Item_ID + !; + $self->debug($query) if ($self->{_debug}); + my $intersect_sth = $db->prepare( $query ); + + $intersect_sth->execute(); + +# get a list of all the matches + my $matches = $intersect_sth->fetchall_arrayref(); + +# strip the matches from the current result set + foreach my $word ( map { $_->[0] } @{$matches}) { + delete $results->{$word}; + } + } + + return $results; +} + +sub _phrase_disjoin_query { +#------------------------------------------------------------ +# subtracts the found phrases from the list + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform disjoin + foreach my $itemid ( keys %{$temp} ) { + $self->debug( "Deleting $itemid from list" ) if ($self->{_debug}); + delete $results->{$itemid}; + } + } + + return $results; +} + +sub _phrase_intersect_query { +#------------------------------------------------------------ +# intersects phrases together + my $self = shift; + my $phrases = shift; + my $results = shift || {}; + + $phrases or return $results; + + foreach my $phrase ( values %{$phrases} ) { + my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} ); + +# perform intersect + foreach my $itemid ( keys %{$temp} ) { + $temp->{$itemid} += $results->{$itemid} || 0; + } + $results = $temp; + + } + + return $results; + +} + +sub _phrase_query { +#------------------------------------------------------------ +# this is a phrase union query + my $self = shift; + my $phrases = shift or return; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + $results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results ); + } + + return $results; + +} + +sub _get_phrase { +#------------------------------------------------------------ + my $self = shift; + my $wordlist= shift; + my $word_info = shift; + my $results = shift || {}; + + $wordlist or return $results; + + my ( $query, $where, $db, $word_infos, %word_hits ); + my ( $table, $wtable, $stable) = $self->_table_names(); + my ($pk) = $self->{table}->pk; + + $self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug}); + +# get all the word ids that we want to handle + $db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' ); + $word_infos = $self->_word_infos( $word_info ) or return; + + + $self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug}); + +# take the words and get a hash of the word scores + foreach my $word ( keys %{$word_infos} ) { + + @{$word_infos->{$word} || []} or return; + + my $total_freq = 0; + foreach my $word_synonyms ( @{$word_infos->{$word}} ) { + $total_freq += $word_synonyms->[1]; + } + +# if the value is null this mean there is actually no results, whoops! + $word_hits{$word} = $total_freq; + } + + $self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug}); + +# so now, setup the order of search + my $i = 0; + my %word_order = map { $_ => $i++ } @{$wordlist}; + my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits; + + $self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug}); + +################################################################################ +### This following part is for smaller phrases +################################################################################ +# start getting words in order of their frequency + my %matches = (); + my $index = 0; + foreach my $word ( @search_order ) { + +# setup the where clause for the individual words, firstly + if ( keys %matches ) { + my $vector = $word_order{$word} - $index; + $where = '('; + $where = + '(' . + join( + " OR ", + map( + "Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')', + keys %matches + ) + ) . + ") AND "; + } + else { + $where = ''; + } + + $where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')'; + + $query = qq! + SELECT + Item_ID, Score, Word_Pos + FROM + $stable + WHERE + $where + !; + + $self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug}); + my $sth = $db->prepare( $query ); + $sth->execute(); + + %matches = (); + + while (my $hit = $sth->fetchrow_arrayref) { + push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ]; + } + +# If there are no values stored in %matches, it means that for +# this keyword, there have been no hits based upon position. +# In that case, terminate and return a null result + keys %matches or last; + +# where were we in the string? + $index = $word_order{$word}; + } + +# now tally up all the scores and merge the new records in + foreach my $itemid ( keys %matches ) { + my $score = 0; + foreach my $sub_total ( @{$matches{$itemid}} ) { + $score += $sub_total->[1]; + } + $results->{$itemid} += $score; + } + + return $results; +} + +sub get_wordids { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $elements = shift or return; + my $mode = lc shift || 'keywords'; + + if ( $mode eq 'keywords' ) { + $elements = $self->_get_wordid($elements); + } + else { + foreach my $phrase ( keys %$elements ) { + my $results = $self->_get_wordid({ + map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}} + }); + + $elements->{$phrase}->{word_info} = $results; + } + } + + return $elements; +} + +sub _get_wordid { +# ------------------------------------------------------------------------------ +# Get a list of words +# + my $self = shift; + my $words = shift; + my $tbl = $self->{table}; + + my ( $table, $wtable, $stable) = $self->_table_names(); + + foreach my $word ( keys %$words ) { + my $query = + qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! . + quotemeta($word) . + ( $words->{$word}->{substring} ? '%' : '' ) . + "'"; + my $sth = $tbl->do_query($query) or next; + my $tmp = { $sth->fetchall_list }; + + $words->{$word}->{word_info} = $tmp; + } + + return $words; +} + +## +# Internal Use +# $self->_cgi_to_hash ($in); +# -------------------------- +# Creates a hash ref from a cgi object. +## +sub _cgi_to_hash { + my ($self, $cgi) = @_; + $cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL'); + my @keys = $cgi->param; + my $result = {}; + foreach my $key (@keys) { + my @values = $cgi->param($key); + if (@values == 1) { $result->{$key} = $values[0] } + else { $result->{$key} = \@values } + } + return $result; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Indexer.pm new file mode 100644 index 0000000..968f4d6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Indexer.pm @@ -0,0 +1,239 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::LUCENE::Indexer +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.2 2006/12/07 22:42:16 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::LUCENE::Indexer; + +# ------------------------------------------------------------------------------ +# Preamble information related to the object +use strict; +use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; +use Lucene; +use GT::SQL::Search::Base::Indexer; +use GT::TempFile; +@ISA = qw/ GT::SQL::Search::Base::Indexer /; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; +$ERRORS = { + INDEX_CORRUPT => 'Could not create an Indexer, this probably means your index is corrupted and you should rebuild it. The error was: %s', + DELETE_FAILED => 'Could not delete some records: %s' +}; +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_) +} + +sub _get_path { + my $self = shift; + my $name = $self->{table}->name; + my $tmpdir = GT::TempFile::find_tmpdir(); + my $path = $tmpdir . '/' . $name; + $path = $1 if $path =~ /(.*)/; # XXX untaint + return $path; +} + +sub _get_store { + my ($self, $create) = @_; + my $path = $self->_get_path; + return Lucene::Store::FSDirectory->getDirectory($path, $create); +} + +sub _get_indexer { + my ($self, $create) = @_; + my %weights = $self->{table}->_weight_cols() or return $self->error(NOWEIGHTS => 'WARN'); + + my ($pk) = $self->{table}->pk; + if (!$pk) { + return $self->error('NOPRIMARYKEY','WARN'); + } + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer; + my $store = $self->_get_store($create); + + my $iw; + eval { $iw = new Lucene::Index::IndexWriter($store, $analyzer, $create); }; + if ($@) { + return $self->error('INDEX_CORRUPT', 'WARN', "$@"); + } + return $iw; +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + my $path = $self->_get_path; + require File::Tools; + File::Tools::deldir($path); + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + $self->_get_indexer(1) or return; + return 1; +} + +sub post_create_table { +# ------------------------------------------------------------------------------ +# creates the index tables.. +# + return $_[0]->add_search_driver(@_); +} + +sub post_drop_table { +# ------------------------------------------------------- +# Remove the index tables. +# + return $_[0]->drop_search_driver(@_); +} + + +sub post_add_record { +# ------------------------------------------------------- +# indexes a single record + my ($self, $rec, $insert_sth, $no_optimize) = @_; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my %weights = $tbl->_weight_cols() or return; + + my $indexer = $self->_get_indexer(0) or return $self->{_debug} ? () : 1; + my $doc = new Lucene::Document; + my ($pk) = $self->{table}->pk; + delete $weights{$pk}; + for my $column_name (keys %weights) { + my $field = Lucene::Document::Field->UnStored($column_name, $rec->{$column_name}); + $field->setBoost($weights{$column_name}); + $doc->add($field); + } + $doc->add(Lucene::Document::Field->Keyword($pk, ($tbl->ai && $insert_sth ? $insert_sth->insert_id : $rec->{$pk}))); + $indexer->addDocument($doc); + $indexer->optimize if !$no_optimize; + $indexer->close; + undef $indexer; + return 1; +} + +sub reindex_all { +# ------------------------------------------------------- + my $self = shift; + my $table = shift; + my $opts = shift; + my $tick = $opts->{tick} || 0; + my $max = $opts->{max} || 5000; + + my $indexer = $self->_get_indexer(1) or return $self->{_debug} ? () : 1; # clobbers the old one + $indexer->close; + undef $indexer; + + my %weights = $self->{table}->_weight_cols() or return; + my @weight_list = keys %weights; + my ($pk) = $self->{table}->pk(); + +# Go through the table and index each field. + my $iterations = 1; + my $count = 0; + + while (1) { + if ($max) { + my $offset = ($iterations-1) * $max; + $table->select_options("LIMIT $offset,$max"); + } + my $cond = $opts->{cond} || {}; + my $sth = $table->select($cond, [$pk, @weight_list]); + my $done = 1; + + while (my $rec = $sth->fetchrow_hashref() ) { + $self->post_add_record($rec, undef, 1); + $done = 0; + if ($tick) { + $count++; + $count % $tick or (print "$count "); + $count % ($tick*10) or (print "\n"); + } + } + last if $done; + $iterations++; + last if !$max; + } + $indexer = $self->_get_indexer(0) or return; + $indexer->optimize; + $indexer->close; + undef $indexer; + return 1; +} + +sub pre_delete_record { +# ------------------------------------------------------- +# Delete a records index values. +# + my ($self, $where) = @_; + + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my ($pk) = $tbl->pk(); + my $q = $tbl->select($where, [$pk]); + + my $reader = eval { Lucene::Index::IndexReader->open($self->_get_store(0)); }; + if ($@) { + return $self->{_debug} ? $self->error('INDEX_CORRUPT', 'WARN', "$@") : 1; + } + + my @errors; + while (my ($item_id) = $q->fetchrow) { + my $t = new Lucene::Index::Term($pk => $item_id); + eval { $reader->deleteDocuments($t); }; + if ($@) { + push @errors, "$@"; + } + } + $reader->close; + undef $reader; + if (@errors) { + return $self->{_debug} ? $self->error('DELETE_FAILED', 'WARN', join(", ", @errors)) : 1; + } + return 1; +} + +sub post_update_record { +# ------------------------------------------------------- + my ( $self, $set_cond, $where_cond, $tmp ) = @_; + +# delete the previous record + eval { + $self->pre_delete_record($where_cond) or return $self->{_debug} ? () : 1; + }; +# +# the new record + my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' ); + my ($pk) = $tbl->pk(); + my %weights = $self->{table}->_weight_cols(); + my @weight_list = keys %weights; + my $q = $tbl->select($where_cond, [$pk, @weight_list]); + while (my $href = $q->fetchrow_hashref) { + $self->post_add_record($href); + } + + return 1; + +} + +sub reindex_record { +# ------------------------------------------------------- +# reindexes a record. basically deletes all associated records from current db abnd does an index. +# it's safe to use this + my ($self, $rec) = @_; + + $self->delete_record($rec); + $self->index_record($rec); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Lucene.txt b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Lucene.txt new file mode 100644 index 0000000..36e464a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Lucene.txt @@ -0,0 +1,206 @@ +NAME + Lucene -- API to the C++ port of the Lucene search engine + +SYNOPSIS + Initialize/Empty Lucene index + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer(); + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 1); + + my $tmp_writer = new Lucene::Index::IndexWriter($store, $analyzer, 1); + $tmp_writer->close; + undef $tmp_writer; + + Choose your Analyzer (string tokenizer) + # lowercases text and splits it at non-letter characters + my $analyzer = Lucene::Analysis::SimpleAnalyzer(); + # same as before and removes stop words + my $analyzer = Lucene::Analysis::StopAnalyzer(); + # splits text at whitespace characters + my $analyzer = Lucene::Analysis::WhitespaceAnalyzer(); + # lowercases text, tokenized it based on a grammer that + # leaves named authorities intact (e-mails, company names, + # web hostnames, IP addresses, etc) and removed stop words + my $analyzer = Lucene::Analysis::Standard::StandardAnalyzer(); + + Choose your Store (storage engine) + # in-memory storage + my $store = new Lucene::Store::RAMDirectory(); + # disk-based storage + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0); + + Open and configure an IndexWriter + my $writer = new Lucene::Index::IndexWriter($store, $analyzer, 0); + # optional settings for power users + $writer->setMergeFactor(100); + $writer->setUseCompoundFile(0); + $writer->setMaxFieldLength(255); + $writer->setMinMergeDocs(10); + $writer->setMaxMergeDocs(100); + + Create Documents and add Fields + my $doc = new Lucene::Document; + # field gets analyzed, indexed and stored + $doc->add(Lucene::Document::Field->Text("content", $content)); + # field gets indexed and stored + $doc->add(Lucene::Document::Field->Keyword("isbn", $isbn)); + # field gets just stored + $doc->add(Lucene::Document::Field->UnIndexed("sales_rank", $sales_rank)); + # field gets analyzed and indexed + $doc->add(Lucene::Document::Field->UnStored("categories", $categories)); + + Add Documents to an IndexWriter + $writer->addDocument($doc); + + Optimize your index and close the IndexWriter + $writer->optimize(); + $writer->close(); + undef $writer; + + Delete Documents + my $reader = Lucene::Index::IndexReader->open($store); + my $term = new Lucene::Index::Term("isbn", $isbn); + $reader->deleteDocuments($term); + $reader->close(); + undef $reader; + + Query index + # initalize searcher and parser + my $analyzer = Lucene::Analysis::SimpleAnalyzer(); + my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0); + my $searcher = new Lucene::Search::IndexSearcher($store); + my $parser = new Lucene::QueryParser("default_field", $analyzer); + + # build a query on the default field + my $query = $parser->parse("perl"); + + # build a query on another field + my $query = $parser->parse("title:cookbook"); + + # define a sort on one field + my $sortfield = new Lucene::Search::SortField("unixtime"); + my $reversed_sortfield = new Lucene::Search::SortField("unixtime", 1); + my $sort = new Lucene::Search::Sort($sortfield); + + # define a sort on two fields + my $sort = new Lucene::Search::Sort($sortfield1, $sortfield2); + + # use Lucene's INDEXORDER or RELEVANCE sort + my $sort = Lucene::Search::Sort->INDEXORDER; + my $sort = Lucene::Search::Sort->RELEVANCE; + + # query index and get results + my $hits = $searcher->search($query); + my $sorted_hits = $searcher->search($query, $sort); + + # get number of results + my $num_hits = $hits->length(); + + # get fields and ranking score for each hit + for (my $i = 0; $i < $num_hits; $i++) { + my $doc = $hits->doc($i); + my $score = $hits->score($i); + my $title = $doc->get("title"); + my $isbn = $doc->get("isbn"); + } + + # free memory and close searcher + undef $hits; + undef $query; + undef $parser; + undef $analyzer; + $searcher->close(); + undef $fsdir; + undef $searcher; + } + + Close your Store + $store->close; + undef $store; + +DESCRIPTION + Like it or not Apache Lucene has become the de-facto standard for + open-source high-performance search. It has a large user-base, is well + documented and has plenty of committers. Unfortunately Apache Lucene is + entirely written in Java and therefore of relatively little use for perl + programmers. Fortunately in the recent years a group of C++ programmers + led by Ben van Klinken decided to port Java Lucene to C++. + + The purpose of the module is to export the C++ Lucene API to perl and at + the same time be as close as possible to the original Java API. This has + the combined advantage of providing perl programmers with a + well-documented API and giving them access to a C++ search engine + library that is supposedly faster than the original. + +CHARACTER SUPPORT + Currently only ISO 8859-1 (Latin-1) characters are supported. Obviously + this included all ASCII characters. + +INDEX COMPATIBLITY + For the moment indices produced by this module are not compatible with + those from Apache Lucene. The reason for this is that this module uses + 1-byte character encoding as opposed to 2-byte (widechar) encoding with + Apache Lucene. + +INSTALLATION + This module requires the clucene library to be installed. The best way + to get it is to go to the following page + + http://sourceforge.net/projects/clucene/ + + and download the latest STABLE clucene-core version. Currently it is + clucene-core-0.9.15. Make sure you compile it in ASCII mode and install + it in your standard library path. + + On a Linux platform this goes as follows: + + wget http://kent.dl.sourceforge.net/sourceforge/clucene/clucene-core-0.9.15.tar.gz + cd clucene-core-0.9.15 + ./autogen.sh + ./configure --disable-debug --prefix=/usr --exec-prefix=/usr --enable-ascii + make + make check + (as root) make install + + To install the perl module itself, run the following commands: + + perl Makefile.PL + make + make test + (as root) make install + +AUTHOR + Thomas Busch + +COPYRIGHT AND LICENSE + Copyright (c) 2006 Thomas Busch + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + +SEE ALSO + Plucene - a pure-Perl implementation of Lucene + + KinoSearch - a search engine library inspired by Lucene + +DISCLAIMER OF WARRANTY + BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY + FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN + OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES + PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER + EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE + ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH + YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL + NECESSARY SERVICING, REPAIR, OR CORRECTION. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR + REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE + TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE + SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING + RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A + FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF + SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH + DAMAGES. + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/STH.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/STH.pm new file mode 100644 index 0000000..e9af838 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/STH.pm @@ -0,0 +1,115 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::STH +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# CVS Info : 087,071,086,086,085 +# $Id: STH.pm,v 1.1 2006/12/07 07:04:51 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::LUCENE::STH; +#-------------------------------------------------------------------------------- +use strict; +use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /; +require GT::SQL::Search::Base::STH; + +@ISA = ('GT::SQL::Search::STH'); +$ATTRIBS = { + 'db_sort' => 1, + 'hits' => undef +}; +$ERROR_MESSAGE = 'GT::SQL::Search::STH'; + + + +sub init { +#-------------------------------------------------------------------------------- +# GT::SQL::Search::STH expects a full set of results in $self->{results}. For +# Lucene the only time a full set of results is there is when we are sorting +# on a field that is not weighted, otherwise the results in $self->{results} is +# the proper page and number of results. + my $self = shift; + + $self->set(@_); + + --$self->{nh} if $self->{nh}; + + # Here we allow hits to override our concept of rows. This is only useful + # when !$self->{db_sort} + $self->{rows} = $self->{hits} + ? $self->{hits} + : $self->{results} + ? scalar(keys %{$self->{results}}) + : 0; + + if ($self->{db_sort}) { + $self->get_db_sorted_results; + } + else { + $self->get_sorted_results; + } +} + +sub get_sorted_results { +# Just sorts the results out of $self->{results} which should have been setup +# by a search driver + my ($self) = @_; + my $results = $self->{results}; + $self->{index} = 0; + $self->{max_index} = $self->{mh} - 1; + $self->{'order'} = [ sort { + ( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 ) + } keys %{$results} ]; + $self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug}); +} + +sub get_db_sorted_results { +# This assumes $self->{results} has a full result set, i.e. without any LIMIT +# It then selects the result set using the SQL driver to do the sorting. This +# is for Search modules which can not handle their own sorting + my ($self) = @_; + + my $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so}); + $self->{index} = $self->{nh} * $self->{mh} || 0; + $self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned. + if ($self->{max_index} > $self->{rows}) { + $self->{max_index} = $self->{rows}; + $self->{rows} = $self->{rows} - $self->{index}; + $self->{rows} < 0 ? $self->{rows} = 0 : 0; + } + + else { + $self->{rows} = $self->{mh}; + } + my ( $table, $pk ) = $self->_table_info(); + my ( $query, $where, $st, $limit ); + + $where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')'; + $self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!; + $query = qq! + SELECT $pk + FROM $table + WHERE $where + $sb + $limit + !; + $self->debug( "Row fetch query: $query" ) if ($self->{_debug}); + my $sth = $self->{table}->{driver}->prepare( $query ); + $sth->execute(); + + $self->{index} = 0; + $self->{max_hits} = $self->{rows}; + + # Fetch the results in sorted order + my $order = $sth->fetchall_arrayref(); + $sth->finish(); + + $self->{'order'} = [ map { $_->[0] } @{$order} ]; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Search.pm new file mode 100644 index 0000000..89fea7a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/LUCENE/Search.pm @@ -0,0 +1,260 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::LUCENE::Search +# Author : Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.2 2006/12/07 22:42:16 aki Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::LUCENE::Search; +# ------------------------------------------------------------------------------ +use strict; +use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS $ERRORS $ERROR_MESSAGE /; +use Lucene; +use GT::TempFile; +use GT::SQL::Search::LUCENE::STH; +use GT::SQL::Search::Base::Search; +@ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; +$ERRORS = { + SEARCH_ERROR => "Error searching: %s", + QUERY_ERROR => "Query error: %s" +}; +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + shift; + return GT::SQL::Search::LUCENE::Search->new(@_) +} + +sub _get_path { + my $self = shift; + my $name = $self->{table}->name; + my $tmpdir = GT::TempFile::find_tmpdir(); + my $path = $tmpdir . '/' . $name; + $path = $1 if $path =~ /(.*)/; # XXX untaint + return $path; +} + +sub _get_store { + my ($self, $create) = @_; + my $path = $self->_get_path; + return Lucene::Store::FSDirectory->getDirectory($path, $create); +} + +sub query { +# -------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# create an easily accessible argument hash + my $args = $self->common_param(@_); + my $tbl = $self->{table}; + +# see if we can setup the filtering constraints + my $filter = { %$args }; + my $query = delete $args->{query} || $self->{query} || ''; + my $ftr_cond; + +# parse query + $self->debug( "Search Query: $query" ) if ($self->{_debug}); + + my ( $query_struct, $rejected ) = $self->_parse_query_string( $query ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query_struct = $self->_preset_options( $query_struct, $args ); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + +# with the buckets, it's now possible to create a query string +# that can be passed directly into the Lucene search. + my $query_string = ''; + + foreach my $search_type ( keys %$buckets ) { + my $bucket = $buckets->{$search_type}; + foreach my $token ( keys %$bucket ) { + next unless $token; + my $properties = $bucket->{$token} or next; + $token =~ s/(["()])/\\$1/g; + $token =~ s/\b(or|and)\b/ /g; + + my $e = ' '; + +# handle boolean operations + $properties->{mode} ||= ''; + if ( $properties->{mode} eq 'must' ) { + $e .= '+'; + } + elsif ( $properties->{mode} eq 'cannot' ) { + $e .= '-'; + } + +# deal with phrase vs keyword + if ( $properties->{phrase} ) { + $e .= '"' . $token . '"' unless $token =~ /^"|"$/; + } + else { + $e .= $token; + +# substring match + if ($properties->{mode} ne 'substring') { + $e .= '*' if $properties->{substring}; + } + } + + $query_string .= $e; + } + } + +# calculate the cursor constraints + foreach my $k (qw( nh mh so sb )) { + next if defined $args->{$k}; + $args->{$k} = $self->{$k} || ''; + } + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25; + $args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score'; + + # Score is the default + $args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)(?:end)?$/i) ? lc($1) : 'asc'; + + my %weights = $tbl->_weight_cols(); + my @sortfields; + my $do_mysql_sort = 0; + for (ref($args->{sb}) eq 'ARRAY' ? @{$args->{sb}} : $args->{sb}) { + if (!exists $weights{$_}) { + $do_mysql_sort = 1 if $_ ne 'score'; + next; + } + push @sortfields, new Lucene::Search::SortField($_, $args->{so} ne 'asc'); + } + my $sort = @sortfields ? new Lucene::Search::Sort(@sortfields) : Lucene::Search::Sort->RELEVANCE; + my $store = $self->_get_store(0); + my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer; + my $searcher = eval { new Lucene::Search::IndexSearcher($store); }; + if ($@) { + $self->{_debug} and $self->error('SEARCH_ERROR', 'WARN', "$@"); + return $self->sth({}, 0); # no hits + } + # Random default field, it's not used + my $parser = new Lucene::MultiFieldQueryParser((keys %weights)[0], $analyzer); + my $pquery = eval { $parser->parse($query_string, [keys %weights], $analyzer); }; + if ($@) { + $self->{_debug} and $self->error('QUERY_ERROR', 'WARN', "$@"); + return $self->sth({}, 0); # no hits + } + my $hits = $searcher->search($pquery, $sort); + my $num_hits = $hits->length; + +## Setup a limit only if there is no callback. The callback argument requires a full results list + my ($offset, $max_hits) = (0, $num_hits); + unless ($self->{callback} or $do_mysql_sort) { + $offset = ( $args->{nh} - 1 ) * $args->{mh}; + $max_hits = $offset + $args->{mh}; + } + $max_hits = $num_hits if $max_hits > $num_hits; + my ($pk) = $self->{table}->pk; + my @indexes; + my $results = {}; + for (my $i= $offset; $i < $max_hits; ++$i) { + my $doc = $hits->doc($i); + my $value = $doc->get($pk); + my $score = $hits->score($i); + $results->{$value} = $score; + } + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $tmp = $_) =~ s/-[lg]t$//; + $cols->{$tmp} ? ($_ => $args->{$_}) : () + } keys %{$args}; + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $results = $self->filter(\%filters, $results); + } + elsif ($self->{filter}) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $results = $self->_filter_query( $self->{filter}, $results ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll dothat here + $self->{filter} = undef; + +# now run through a callback function if needed. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + $self->{_debug} and $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + return $self->sth({}, 0); # no hits + } + $self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + } + + $self->{rows} = $num_hits; + + return $self->sth($results, $do_mysql_sort); +} + +sub sth { +#-------------------------------------------------------------------------------- + my ($self, $results, $db_sort) = @_; + + my $sth = GT::SQL::Search::LUCENE::STH->new( + 'results' => $results, + 'hits' => $self->{rows}, + 'db' => $self->{table}->{driver}, + 'db_sort' => $db_sort, +# pass the following attributes down to the STH handler + map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /) + ); + + return $sth; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Indexer.pm new file mode 100644 index 0000000..75798ae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Indexer.pm @@ -0,0 +1,98 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Indexer +# Author: Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.6 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Supports MS SQL full text indexer on MS SQL 2000 only. +# + +package GT::SQL::Search::MSSQL::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/; + + $ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MSSQLNONSUPPORT => 'You must be using MS SQL 2000 in order to use full text indexing. Current Database: %s', + CREATEINDEX => 'Problem Creating Full Text Index: %s' + }; + $ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +#-------------------------------------------------------------------------------- + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'ODBC') { + return $class->error ('MSSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + return 1; +} + +sub drop_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + + my $res = eval { + $table->do_query(" sp_fulltext_table '$name', 'drop' "); + $table->do_query(" sp_fulltext_catalog '$cat', 'drop' "); + 1; + }; + $res ? return 1 : return; +} + +sub add_search_driver { +#-------------------------------------------------------------------------------- + my $self = shift; + my $table = $self->{table}; + my $name = $table->name; + my $cat = $name . '_ctlg'; + my %weights = $table->weight; + my ($pk) = $table->pk; + +# Enable a database for full text indexing + $table->do_query(" sp_fulltext_database 'enable' ") or $self->error('CREATEINDEX', 'FATAL', $GT::SQL::error); +# Create a full text catalog to store the data. + $table->do_query(" sp_fulltext_catalog '$cat', 'create' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Make a unique index on primary key (not sure why it isn't by default. + $table->do_query(" create unique index PK_$name on $name ($pk) "); +# Mark this table as using the full text catalog created + $table->do_query(" sp_fulltext_table '$name', 'create', '$cat', 'PK_$name' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); +# Specify which columns are to be indexed + foreach my $col (keys %weights) { + if ($weights{$col}) { + $table->do_query(" sp_fulltext_column '$name', '$col', 'add' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + } + } +# Must have a timestamp field. + $table->do_query(" alter table $name add timestamp "); +# Build the index. + $table->do_query(" sp_fulltext_table '$name', 'start_change_tracking' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + $table->do_query(" sp_fulltext_table '$name', 'start_background_updateindex' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error); + + return 1; +} + +sub post_create_table { +#-------------------------------------------------------------------------------- + shift->add_search_driver(@_); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Search.pm new file mode 100644 index 0000000..1c9ff62 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MSSQL/Search.pm @@ -0,0 +1,179 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MSSQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.9 2004/08/28 03:53:48 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MSSQL::Search; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +#-------------------------------------------------------------------------------- +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 2, + }; + +sub load { + shift; + return GT::SQL::Search::MSSQL::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# overruns the usual query system with the mssql version +# + my $self = shift; + +# Find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# Add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# Parse query..., + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + $self->{'rejected_keywords'} = $rejected; + +# Setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + +# Now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $string = $self->_string ($buckets); + + return $self->sth({}) unless ($string =~ /\w/); + + my $table_name = $tbl->name(); + my ($pk) = $tbl->pk; + +# create the filter + my $filter_sql = $self->{filter} ? "WHERE ( " . $self->{filter}->sql . ' )' : ''; + +# If we have a callback, we need all results. + if ($self->{callback}) { + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my %results = $tbl->do_query($query)->fetchall_list; + my $results = $self->{callback}->($self, \%results); + $self->{rows} = $results ? scalar keys %$results : 0; + return $self->sth($results); + } + else { + my $mh = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + my $nh = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; +# First get the total. + $query = qq! + SELECT COUNT(*) + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + !; + my ($count) = $tbl->do_query($query)->fetchrow; + +# Now get results. + $query = qq! + SELECT $pk, K.RANK + FROM $table_name AS T INNER JOIN + CONTAINSTABLE ( $table_name, *, + '$string' + ) AS K + ON T.$pk = K.[KEY] + $filter_sql + ORDER BY K.RANK DESC + !; + my %results = $tbl->do_query($query)->fetchall_list; + $self->{rows} = $count; + return $self->sth(\%results); + } +} + +sub _string { +# ------------------------------------------------------------------- +# Returns the string to use for containstable. +# + my ($self, $buckets) = @_; + +# union + my $tmp_bucket = $buckets->{keywords}; + my $union_request_str = join( + " or ", + map( + qq!"$_"!, + keys %{$buckets->{phrases}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# intersect + $tmp_bucket = $buckets->{keywords_must}; + my $intersect_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_must}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# disjoin + $tmp_bucket = $buckets->{keywords_cannot}; + my $disjoin_request_str = join( + " and ", + map( + qq!"$_"!, + keys %{$buckets->{phrases_cannot}} + ), + map( + ($tmp_bucket->{$_}->{substring} ? "$_*" : $_), + keys %$tmp_bucket + ) + ); + +# now build the query + my $tmp_request_str = join( + " and ", + ($union_request_str ? "( $union_request_str )" : ()), + ($intersect_request_str ? "( $intersect_request_str )" : ()), + ($disjoin_request_str ? "NOT ( $disjoin_request_str )" : ()) + ); + return $tmp_request_str; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Indexer.pm new file mode 100644 index 0000000..24e47c7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Indexer.pm @@ -0,0 +1,187 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Indexer +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.17 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Indexer; +# ------------------------------------------------------------------------------ +use strict; +use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/; +use GT::SQL::Search::Base::Indexer; +@ISA = qw/GT::SQL::Search::Base::Indexer/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/; + +$ERRORS = { + NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.', + MYSQLNONSUPPORT => 'Driver MYSQL requires MySQL version 3.23.23 or greater. Currently MySQL version: %s' +}; + +@$GT::SQL::ERRORS{ keys %$ERRORS } = values %$ERRORS; + +$ERROR_MESSAGE = 'GT::SQL'; + +sub load { + my $class = shift; + return $class->new(@_); +} + +sub ok { +# ------------------------------------------------------------------------------ + my ($class, $tbl) = @_; + unless (uc $tbl->{connect}->{driver} eq 'MYSQL') { + return $class->error ('MYSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver}); + } + my $sth = $tbl->do_query(qq!SELECT VERSION()!); + my $version = $sth->fetchrow; + my ($maj, $min) = split (/\./, $version); + unless ($maj > 3 or ($maj == 3 and $min >= 23)) { + return $class->error(MYSQLNONSUPPORT => WARN => $version); + } + return 1; +} + +sub drop_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return; + $tbl->connect(); + + my %weights = $tbl->weight() or return; + my $tblname = $tbl->name(); + +# Group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Drop unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# For each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + DROP INDEX $ft_name + !); + }; + +# Break on errors that can't be handled + if ( $@ ) { + next if $@ !~ /exist/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; +} + +sub add_search_driver { +# ------------------------------------------------------------------------------ + my $self = shift; + + $self->too_much() and return; + + my $tbl = $self->{table} or return $self->error(BADARGS => FATAL => "table must be passed into add_search_driver."); + my %weights = $tbl->weight() or return $self->error(NOWEIGHTS => 'WARN'); + my $tblname = $tbl->name() or return $self->error(BADARGS => FATAL => "table does not have a name?"); + +# group the fulltext columns by value of the weight + my %cols_grouped; + foreach ( keys %weights ) { + my $val = $weights{$_} or next; + push @{$cols_grouped{$val}}, $_; + } + +# Create unified fulltext columns if required + if ( keys %cols_grouped > 1 ) { + $cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ]; + } + +# for each value grouped column set create a full text +# column + foreach my $v ( keys %cols_grouped ) { + + my $cols = join(",", sort @{$cols_grouped{$v}}); + my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}}); + + my $res = eval { + $tbl->do_query(qq! + ALTER TABLE $tblname + ADD FULLTEXT $ft_name ( $cols ) + !); + }; + +# break on errors that can't be handled + if ( $@ ) { + next if $@ =~ /duplicate/i; + $self->warn( "$@" ); + return; + } + + } + + return 1; + +} + +sub too_much { +# ------------------------------------------------------------------------------ +# returns true if there are too many records to be used on the Web +# + if ( $ENV{REQUEST_METHOD} ) { + my $self = shift; + my $tbl = $self->{table}; + if ( $tbl->count() > 5000 ) { + $self->error( 'NOTFROMWEB', 'WARN', $tbl->name() ); + return 1 + } + } + return; +} + +sub post_create_table { +# ------------------------------------------------------------------------------ + shift->add_search_driver(@_); +} + +sub reindex_all { +# ------------------------------------------------------------------------------ +# this will drop all the fulltext columns and reindex all of them. This should +# not be required unless the user changes the weights on one of their columns. +# Unfortunately, this method is not particularly smart and risks not dropping +# certain index columns and reindexes even when it's not required. It must be +# recoded at a future date, but as this action won't happen frequently and will +# rarely affect the user, it is not a priority. +# + my $self = shift; + + $self->drop_search_driver; + $self->add_search_driver; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Search.pm new file mode 100644 index 0000000..69165d7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/Search.pm @@ -0,0 +1,51 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::Search +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.14 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::Search; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub load { +# -------------------------------------------------- + my $self = shift; + my $opts = $self->common_param( @_ ); + +# determine which mysql search variant to use. + my $tbl = $opts->{table}; + my $ver_sth = $tbl->do_query( 'SELECT VERSION()' ); + my $version = $ver_sth->fetchrow_array(); + + my ( $maj, $min ) = split /\./, $version; + + my $pkg = 'GT::SQL::Search::MYSQL::'; + $pkg .= $maj > 3 ? 'VER4' : 'VER3'; + + eval "require $pkg"; + return $pkg->new(@_) +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER3.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER3.pm new file mode 100644 index 0000000..83c2638 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER3.pm @@ -0,0 +1,178 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER3 +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: VER3.pm,v 1.3 2004/08/28 03:53:49 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER3; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { + min_word_size => 4 + }; + +sub _phrase_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + foreach my $phrase ( values %{$phrases} ) { + $self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug}); + + my $tmp = {}; + foreach my $keyword ( @{ $phrase->{phrase}|| [] } ) { + $tmp = $self->_get_words ( [ $keyword ], $tmp, 'intersect' ); + keys %$tmp or return {}; + } + foreach my $key ( keys %$tmp ) { $results->{$key} += $tmp->{$key} } + + } + + return $results; +} + +sub _get_phrase { +# ------------------------------------------------------------------------------ +# one day change this so it does words properly + return _get_words(@_); +} + +sub _union_query { +# ------------------------------------------------------------------------------ + return _get_words(@_); +} + +sub _intersect_query { +# ------------------------------------------------------------------------------ + my ( $self, $keywords, $results ) = @_; + $keywords or return $results; + + foreach my $keyword ( keys %{ $keywords || {} } ) { + $results = $self->_get_words ( [ $keyword ], $results, 'intersect' ); + keys %$results or return {}; + } + + return $results; +} + +sub _phrase_intersect_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return $_[0]; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + if ( $tmp->{$key} ) { + $results->{$key} += $tmp->{$key}; + } + else { + delete $results->{$key} + } + } + + return $results; +} + +sub _disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return shift; + my $results = shift || {}; + + $results = $self->_get_words([ keys %{$words || {}} ], $results, 'disjoin' ); + + return $results; +} + +sub _phrase_disjoin_query { +# ------------------------------------------------------------------------------ + my $self = shift; + my $phrases = shift or return shift; + my $results = shift || {}; + + my $tmp = $self->_phrase_query ( $phrases, $results ); + keys %$results or return $tmp; + foreach my $key ( keys %$results ) { + $tmp->{$key} and delete $results->{$key}; + } +} + +sub _get_words { +# ------------------------------------------------------------------------------ + my $self = shift; + my $words = shift or return $_[0] || {}; + my $results = shift || {}; + my $mode = lc shift; + + my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' ); + my $tname = $tbl->name(); + my $wordlist = join " ", ( ref $words ? ( ref $words eq 'HASH' ? keys %$words : @$words ) : $words ) ; + my ($pk) = $tbl->pk; + + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + my $qwrds = quotemeta( $wordlist ); + my $where = ( $results and keys %$results ) + ? ("AND $pk IN(" . join(',', keys %$results) . ")") + : ''; + my $query = qq! + SELECT $pk, MATCH($cols) AGAINST ('$qwrds') AS SCORE + FROM $tname + WHERE MATCH($cols) AGAINST ('$qwrds') + $where + !; + my $sth = $tbl->do_query( $query ) or return; + + if ( $mode eq 'disjoin' ) { + while ( my $result = $sth->fetchrow ) { + delete $results->{$result}; + } + } + elsif ( $mode eq 'intersect' ) { + my $tmp = {}; + while ( my $aref = $sth->fetchrow_arrayref ) { + $tmp->{$aref->[0]} = $aref->[1]; + } + if ( $results and keys %$results ) { + while (my ($id, $score) = each %$results) { + if (not defined $tmp->{$id}) { + delete $results->{$id}; + next; + } + $results->{$id} += $score; + } + } + else { + $results = $tmp; + } + } + else { + while ( my $aref = $sth->fetchrow_arrayref ) { + $results->{$aref->[0]} += $aref->[1]; + } + } + return $results; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER4.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER4.pm new file mode 100644 index 0000000..43863b4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/MYSQL/VER4.pm @@ -0,0 +1,355 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Search::MYSQL::VER4 +# Author : Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: VER4.pm,v 1.9 2004/01/13 01:35:19 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to search indexed tables. +# + +package GT::SQL::Search::MYSQL::VER4; +# ------------------------------------------------------------------------------ + use strict; + use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS /; + use GT::SQL::Search::Base::Search; + @ISA = qw( GT::SQL::Search::Base::Search ); + +# ------------------------------------------------------------------------------ +# Preamble information related to the object + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/; + $STOPWORDS = { map { $_ => 1 } qw/ + + a's able about above according accordingly across actually after + afterwards again against ain't all allow allows almost alone + along already also although always am among amongst an and another + any anybody anyhow anyone anything anyway anyways anywhere apart + appear appreciate appropriate are aren't around as aside ask asking + associated at available away awfully be became because become becomes + becoming been before beforehand behind being believe below beside + besides best better between beyond both brief but by c'mon c's came + can can't cannot cant cause causes certain certainly changes clearly + co com come comes concerning consequently consider considering + contain containing contains corresponding could couldn't course currently + definitely described despite did didn't different do does doesn't + doing don't done down downwards during each edu eg eight either else + elsewhere enough entirely especially et etc even ever every everybody + everyone everything everywhere ex exactly example except far few + fifth first five followed following follows for former formerly + forth four from further furthermore get gets getting given gives + go goes going gone got gotten greetings had hadn't happens hardly + has hasn't have haven't having he he's hello help hence her here + here's hereafter hereby herein hereupon hers herself hi him himself + his hither hopefully how howbeit however i'd i'll i'm i've ie if ignored + immediate in inasmuch inc indeed indicate indicated indicates inner + insofar instead into inward is isn't it it'd it'll it's its itself + just keep keeps kept know knows known last lately later latter latterly + least less lest let let's like liked likely little look looking looks + ltd mainly many may maybe me mean meanwhile merely might more + moreover most mostly much must my myself name namely nd near nearly + necessary need needs neither never nevertheless new next nine no + nobody non none noone nor normally not nothing novel now nowhere + obviously of off often oh ok okay old on once one ones only onto + or other others otherwise ought our ours ourselves out outside over + overall own particular particularly per perhaps placed please plus + possible presumably probably provides que quite qv rather rd re + really reasonably regarding regardless regards relatively respectively + right said same saw say saying says second secondly see seeing seem + seemed seeming seems seen self selves sensible sent serious seriously + seven several shall she should shouldn't since six so some somebody + somehow someone something sometime sometimes somewhat somewhere + soon sorry specified specify specifying still sub such sup sure + t's take taken tell tends th than thank thanks thanx that that's + thats the their theirs them themselves then thence there there's + thereafter thereby therefore therein theres thereupon these they + they'd they'll they're they've think third this thorough thoroughly + those though three through throughout thru thus to together too + took toward towards tried tries truly try trying twice two un + under unfortunately unless unlikely until unto up upon us use used + useful uses using usually value various very via viz vs want wants + was wasn't way we we'd we'll we're we've welcome well went were + weren't what what's whatever when whence whenever where where's + whereafter whereas whereby wherein whereupon wherever whether + which while whither who who's whoever whole whom whose why will + willing wish with within without won't wonder would would wouldn't + yes yet you you'd you'll you're you've your yours yourself + yourselves zero + + / }; + + $ATTRIBS = { + min_word_size => 4, + stopwords => $STOPWORDS, + }; + +sub query { +# -------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# create an easily accessible argument hash + my $args = $self->common_param(@_); + +# see if we can setup the filtering constraints + my $filter = { %$args }; + my $query = delete $args->{query} || $self->{query} || ''; + my $ftr_cond; + +# parse query + $self->debug( "Search Query: $query" ) if ($self->{_debug}); + my ( $query_struct, $rejected ) = $self->_parse_query_string( $query ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query_struct = $self->_preset_options( $query_struct, $args ); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + +# with the buckets, it's now possible to create a query string +# that can be passed directly into the FULLTEXT search. + my $query_string = ''; + + foreach my $search_type ( keys %$buckets ) { + my $bucket = $buckets->{$search_type}; + foreach my $token ( keys %$bucket ) { + next unless $token; + my $properties = $bucket->{$token} or next; + + my $e = ' '; + +# handle boolean operations + $properties->{mode} ||= ''; + if ( $properties->{mode} eq 'must' ) { + $e .= '+'; + } + elsif ( $properties->{mode} eq 'cannot' ) { + $e .= '-'; + } + +# deal with phrase vs keyword + if ( $properties->{phrase} ) { + $e .= '"' . quotemeta( $token ) . '"'; + } + else { + $e .= quotemeta $token; + +# substring match + $e .= '*' if $properties->{substring}; + } + + $query_string .= $e; + } + } + +# start building the GT::SQL::COndition object that will allow us to +# to retreive the data + + require GT::SQL::Condition; + my $tbl = $self->{table}; + my $constraints = GT::SQL::Condition->new; + +# create the GT::SQL::Condition object that will become the filtering +# constraints + my $filt = $self->{filter}; + + if ( $filt and ref $filt eq 'HASH' ) { + foreach my $fkey ( keys %$filt ) { + next if exists $args->{$fkey}; + $args->{$fkey} = $filt->{$fkey}; + } + } + + if ( my $filter_cond = $tbl->build_query_cond( $args ) ) { + $constraints->add( $filter_cond ); + } + +# if the cached filter object is a Condition object, append +# it to the filter set + if ( $filt and UNIVERSAL::isa( $filt, 'GT::SQL::Condition' ) ) { + $constraints->add( $filt ); + } + +# create our fulltext query condition + my %weights = $tbl->_weight_cols(); + my $cols = join(",", keys %weights); + if ( $query_string ) { + $constraints->add( GT::SQL::Condition->new( + "MATCH( $cols )", + "AGAINST", + \"('$query_string' IN BOOLEAN MODE)" ) ); + } + +# calculate the cursor constraints + foreach my $k (qw( nh mh so sb )) { + next if defined $args->{$k}; + $args->{$k} = $self->{$k} || ''; + } + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25; + $args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score'; + +# if the sorting method is "score" the order is forced to "descend" (as there +# is almost no reason to order by worst matches) +# if the storing key is not "score", the default order will be "ascend" + $args->{so} = + $args->{sb} eq 'score' ? 'desc' : # comment out this entire line to prevent "descend" order forcing + ( (defined $args->{so} and $args->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : 'asc' ); + +# check that sb is not dangerous + my $sb = $self->clean_sb($args->{sb}, $args->{so}); + + $self->debug_dumper( "About to query. Constraint object: ", $constraints) if ($self->{_debug}); + +# Setup a limit only if there is no callback. The callback argument requires a full results list + unless ( $self->{callback} ) { + my $offset = ( $args->{nh} - 1 ) * $args->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $args->{mh}"); + } + + my $sth; + +# if the weights are all the same value, the query can be optimized +# to use just one MATCH AGAINST argument. However, if the weights +# are different, each element must be sectioned and queried separately +# with the weight value multipler + +# check to see if all the weight values are the same. + my $base_weight; + my $weights_same = 1; + foreach ( values %weights ) { + $base_weight ||= $_ or next; # init and skip 0s + next if $base_weight == $_; + $weights_same = 0; + last; + } + +# multiplex the action + my $result_cols = $self->{callback} ? ($tbl->pk)[0] : '*'; + + unless ( $query_string ) { + $sth = $tbl->select( [ $result_cols ], $constraints ) or return; + } + elsif ( $weights_same ) { + $sth = $tbl->select( [ $result_cols, "MATCH($cols) AGAINST ('$query_string' IN BOOLEAN MODE) AS score" ], $constraints ) + or return; + } + else { + +# group the multiplier counts + my %column_multiplier; + foreach ( keys %weights ) { + push @{$column_multiplier{$weights{$_}}}, $_; + } + + my @search_parameters; + foreach my $val ( keys %column_multiplier ) { + next unless $val; + + my $cols_ar = $column_multiplier{ $val } or next; + my $search_cols = join ",", @$cols_ar; + + if ( $val > 1 ) { + push @search_parameters, "( ( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) ) * $val )"; + } + else { + push @search_parameters, "( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) )"; + } + } + + my $search_sql = "( " . join( " + ", @search_parameters ) . " ) AS score"; + + $sth = $tbl->select( [ $result_cols, $search_sql ], $constraints ) + or return; + } + +# If we have a callback, we fetch the primary key => score and pass that hash into +# the filter. + if ($self->{callback}) { + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + my %results = map { $_->[0] => $_->[1] } @{$sth->fetchall_arrayref}; + + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %results) . " results.", \%results) if ($self->{_debug}); + my $filtered = $self->{callback}->($self, \%results) || {}; + $self->debug_dumper("New result set: " . scalar (keys %$filtered) . " results.", $filtered) if ($self->{_debug}); + + $self->{rows} = scalar keys %$filtered; + return $self->sth($filtered); + } + +# count the number of hits. create a query for this purpose only if we are required to. + $self->{rows} = $sth->rows(); + if (($args->{nh} > 1) or ($self->{rows} == $args->{mh})) { + $self->{rows} = $tbl->count($constraints); + } + return $sth; +} + +sub clean_sb { +# ------------------------------------------------------------------------------- +# Convert the sort by, sort order into an sql string. +# + my ($class, $sb, $so) = @_; + my $output = ''; + + return $output unless ($sb); + + if ($sb and not ref $sb) { + if ($sb =~ /^[\w\s,]+$/) { + if ($sb =~ /\s(?:asc|desc)/i) { + $output = 'ORDER BY ' . $sb; + } + else { + $output = 'ORDER BY ' . $sb . ' ' . $so; + } + } + else { + $class->error('BADSB', 'WARN', $sb); + } + } + elsif (ref $sb eq 'ARRAY') { + foreach ( @$sb ) { + /^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next; + } + $output = 'ORDER BY ' . join(',', @$sb); + } + return $output; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Indexer.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Indexer.pm new file mode 100644 index 0000000..bddcc9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Indexer.pm @@ -0,0 +1,25 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Indexer +# Author: Aki Mimoto +# CVS Info : 087,071,086,086,085 +# $Id: Indexer.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# + +package GT::SQL::Search::NONINDEXED::Indexer; +#-------------------------------------------------------------------------------- + use strict; + use vars qw/@ISA $DEBUG/; + use GT::SQL::Search::Base::Indexer; + @ISA = qw/ GT::SQL::Search::Base::Indexer /; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Indexer->new(@_) +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Search.pm new file mode 100644 index 0000000..94b6334 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search/NONINDEXED/Search.pm @@ -0,0 +1,257 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Search::NONINDEXED::Search +# Author : Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Search.pm,v 1.30 2006/08/09 06:58:39 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Nonindex search system +# + +package GT::SQL::Search::NONINDEXED::Search; +# ================================================================== + use strict; + use vars qw/@ISA $ATTRIBS $VERSION $DEBUG/; + use GT::SQL::Search::Base::Search; + use GT::SQL::Condition; + @ISA = qw( GT::SQL::Search::Base::Search ); + + $DEBUG = 0; + $VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/; + $ATTRIBS = { +# parse based on latin characters + latin_query_parse => 0 + }; + +sub load { + shift; + return GT::SQL::Search::NONINDEXED::Search->new(@_) +} + +sub query { +#-------------------------------------------------------------------------------- +# Returns a sth based on a query +# +# Options: +# - paging +# mh : max hits +# nh : number hit (or page of hits) +# +# - searching +# ww : whole word +# ma : 1 => OR match, 0 => AND match, undefined => QUERY +# substring : search for substrings of words +# bool : 'and' => and search, 'or' => or search, '' => regular query +# query : the string of things to ask for +# +# - filtering +# field_name : value # Find all rows with field_name = value +# field_name : ">value" # Find all rows with field_name > value. +# field_name : " value. +# field_name-lt : value # Find all rows with field_name < value. +# +# Parameters: +# ( $CGI ) : a single cgi object +# ( $HASH ) : a hash of the parameters +# + my $self = shift; + +# find out what sort of a parameter we're dealing with + my $input = $self->common_param(@_); + +# add additional parameters if required + foreach my $parameter ( keys %{$ATTRIBS} ) { + if ( not exists $input->{$parameter} ) { + $input->{$parameter} = $self->{$parameter}; + } + } + +# parse query + $self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug}); + my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} ); + + $self->{rejected_keywords} = $rejected; + +# setup the additional input parameters + $query = $self->_preset_options( $query, $input ); + + $self->debug( "Set the pre-options: ", $query ) if ($self->{_debug}); + +# now sort into distinct buckets + my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query ); + $self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug}); + + + require GT::SQL::Condition; + my $query_condition = new GT::SQL::Condition; + +# now handle the separate possibilities +# the union + my $union_cond = $self->_get_condition( $buckets->{keywords}, $buckets->{phrases} ); + $query_condition->add(GT::SQL::Condition->new(@$union_cond, 'OR')) if $union_cond; +# the intersect + my $intersect_cond = $self->_get_condition( $buckets->{keywords_must}, $buckets->{phrases_must} ); + $query_condition->add(GT::SQL::Condition->new(@$intersect_cond)) if $intersect_cond; + +# the disjoin + my $disjoin_cond = $self->_get_condition( $buckets->{keywords_cannot}, $buckets->{phrases_cannot} ); + $query_condition->add(GT::SQL::Condition->new(@$disjoin_cond, 'OR')->not) if $disjoin_cond; + +# now handle filters + my $cols = $self->{'table'}->cols(); + my %filters = map { + (my $column = $_) =~ s/-[lg]t$//; + exists $cols->{$column} + ? ($_ => $input->{$_}) + : () + } keys %{$input}; + +# if there was no query nor filter return nothing. + keys %$query or keys %filters or return $self->sth({}); + + if (keys %filters) { + $self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug}); + $self->_add_filters( \%filters ); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + elsif ($self->{filter} and keys %{$self->{filter}} ) { + $self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug}); + $query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} ); + } + else { + $self->debug( "No filters being used.") if ($self->{_debug}); + } + +# now this query should probably clear the filters once it's been used, so i'll do that here + $self->{filter} = undef; + + my $tbl = $self->{table}; + my ($pk) = $tbl->pk; + +# now run through a callback function if needed. + if ($self->{callback}) { + +# Warning: this slows things a heck of a lot. + unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') { + return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!"); + } + + my $sth = $tbl->select( [ $pk ], $query_condition ); + my $results = {}; + while (my $result = $sth->fetchrow) { + $results->{$result} = undef; + } + $self->debug_dumper("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $results = $self->{callback}->($self, $results); + $self->debug_dumper("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug}); + $self->{rows} = scalar($results ? keys %{$results} : ()); + + return $self->sth( $results ); + } + +# and now create a search sth object to handle all this + $input->{nh} = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1; + $input->{mh} = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25; + $input->{so} = (defined $input->{so} and $input->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : ''; + +# check that sb is not dangerous + my $sb = $self->clean_sb($input->{sb}, $input->{so}); + + my $offset = ( $input->{nh} - 1 ) * $input->{mh}; + $tbl->select_options($sb) if ($sb); + $tbl->select_options("LIMIT $offset, $input->{mh}"); + my $sth = $tbl->select( $query_condition ) or return; + +# so how many hits did we get? + $self->{rows} = $sth->rows(); + if (($input->{nh} > 1) or ($self->{rows} == $input->{mh})) { + $self->{rows} = $tbl->count($query_condition); + } + return $sth; +} + +sub _get_condition { +#------------------------------------------------------------------------------- + my ( $self, $keywords, $phrases ) = @_; + + my @list = ( keys %$keywords, keys %$phrases ); + + my $tbl = $self->{table} or return $self->error( 'NODRIVER', 'FATAL' ); + my @cond = (); + my %tmp = $tbl->weight(); + my @weights = keys %tmp or return; + foreach my $element ( @list ) { + my @where = (); + foreach my $cols ( @weights ) { + push @where, [$cols, 'LIKE', "%$element%"]; # Condition does quoting by default. + } + push @cond, GT::SQL::Condition->new(@where, 'OR'); + } + @cond or return; + + return \@cond; +} + +sub _parse_query_string { +#------------------------------------------------------------ +# Parses a query string '+foo -"bar this" alpha' into a hash of +# words and modes. +# + my ($self, $text) = @_; + my %modes = ( + '+' => 'must', + '-' => 'cannot', + '<' => 'greater', + '>' => 'less' + ); + +# Latin will break up on actual words and punctuation. + if ($self->{latin_query_parse}) { + return $self->SUPER::_parse_query_string( $text ); + } + else { + my $words = {}; + my @terms; + my $i = 0; + foreach my $term (split /"/, $text) { + push @terms, ($i++ % 2 ? $term : split ' ', $term); + } + for (my $i = 0; $i < @terms; $i++) { + my $word = $terms[$i]; + $word =~ s/^\s*|\s*$//g; + next if ($word eq ''); + if ($i < $#terms) { + ($word eq '-') and ($word = '-' . $terms[++$i]); + ($word eq '+') and ($word = '+' . $terms[++$i]); + } + $word =~ s/^([<>+-])//; + my $mode = ($1 and $modes{$1} or 'can'); + my $substring = ($word =~ s/\*$//) || 0; + if ($word =~ /\s/) { + $words->{$word} = { + mode => $mode, + phrase => 1, + substring => $substring, + keyword => 0, + }; + } + elsif ($word) { + $words->{$word} = { + mode => $mode, + phrase => 0, + substring => $substring, + keyword => 1, + }; + } + } + return $words; + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Table.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Table.pm new file mode 100644 index 0000000..15ad4b9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Table.pm @@ -0,0 +1,3006 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# CVS Info : 087,071,086,086,085 +# $Id: Table.pm,v 1.274 2008/09/17 19:35:24 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to store and retrieve data from a table. +# + +package GT::SQL::Table; +# =============================================================== +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::Config; +use GT::AutoLoader(NAME => '_AUTOLOAD'); +use strict; +use vars qw/$DEBUG $VERSION @ISA $AUTOLOAD $ERROR_MESSAGE @COL_ATTRIBS/; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.274 $ =~ /(\d+)\.(\d+)/; +@COL_ATTRIBS = qw/size type values default not_null pos regex weight form_display form_size form_type form_names form_values time_check/; +$ERROR_MESSAGE = 'GT::SQL'; + +use constants DEF_HEADER => <<'HEADER'; +# Database definition file for '%TABLE_NAME%' table +# Last updated: [localtime] +# Created by GT::SQL::Table $Revision: 1.274 $ +HEADER + +sub new { +# ----------------------------------------------------------------------------- +# GT::SQL::Table->new( +# name => table_name, +# debug => debug level, +# _err_pkg => package name, +# driver => driver name, +# ); +# ----------------------------------------------------------------------------- +# Constructs (or returns if it already exists) a new GT::SQL::Object with the +# parameters specified above. +# + my $this = shift; + my $class = ref $this || $this; + my $self = bless {}, $class; + + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->new(HASH or HASH_REF or CGI) only'); + + $self->{connect} = $opts->{connect} || {}; + $self->{_debug} = $opts->{debug} || $DEBUG; + $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__; + $self->{_index} = 0; + $self->{_file} = 0; + +# Must have {connect} info first. + $self->name($opts->{name}); + $self->{name} ||= ''; + if (-f "$self->{connect}->{def_path}/$self->{name}.def" and not $opts->{_schema}) { + $self->load_state; + } + elsif ($opts->{_schema} and UNIVERSAL::isa($opts->{_schema}, 'GT::Config')) { + # If _schema is passed as a GT::Config object, use it directory. This + # is primarily used for subclassed tables - see GT::SQL::Base::new_table() + $self->{schema} = $opts->{_schema}; + } + else { + $self->{schema} = { %{$opts->{_schema}} } if $opts->{_schema}; + $self->_new_schema if length $self->{name}; + } + +# Some defaults for writing to + $self->{schema}->{index} ||= {}; + $self->{schema}->{unique} ||= {}; + $self->{schema}->{cols} ||= {}; + $self->{schema}->{pk} ||= []; + $self->{schema}->{fk} ||= {}; + $self->{schema}->{subclass} ||= {}; + $self->{schema}->{ai} ||= ''; + $self->{schema}->{fk_tables} ||= []; + + { # Check for weights or file columns and set _file and _index accordingly + my ($found_file, $found_weight); + my $c = $self->{schema}->{cols}; + for (keys %$c) { + if (!$found_file and $c->{$_}->{form_type} and uc $c->{$_}->{form_type} eq 'FILE') { + $self->_file_cols(); + $self->{_file} = ++$found_file; + } + if (!$found_weight and $c->{$_}->{weight}) { + $self->{_index} = ++$found_weight; + } + last if $found_file and $found_weight; + } + } + + $self->debug("Table '$self->{name}' object created.") if ($self->{_debug} > 2); + return $self; +} + +sub DESTROY {} + +sub AUTOLOAD { +# ------------------------------------------------------------- +# This method provides get methods for all the cols attributes. +# It returns a hash reference of the column names to the value +# of the attribute for that attribute. +# + my $self = $_[0]; + my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/; + +# Otherwise we have auto generated functions for each of the +# column names. + if (grep { $what eq $_ } @COL_ATTRIBS) { + no strict 'refs'; + *$AUTOLOAD = sub { + my $self = shift; + my $h = {}; + for my $col (keys %{$self->{schema}->{cols}}) { + if (exists $self->{schema}->{cols}->{$col}->{$what}) { + $h->{$col} = $self->{schema}->{cols}->{$col}->{$what}; + } + } + wantarray ? %$h : $h; + }; + goto &$AUTOLOAD; + } + +# Pass to the imported &_AUTOLOAD, which handles loading from %COMPILE + goto &_AUTOLOAD; +} + +# Loads a new ->{schema} GT::Config object that, when saved, will create the +# def file. The config object created is always empty, but any existing values +# in ->{schema} will be copied into the object. Thus, saving will always +# overwrite anything stored in this table's def file. +$COMPILE{_new_schema} = __LINE__ . <<'END_OF_SUB'; +sub _new_schema { + my $self = shift; + my $name = $self->name; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + my %old = $self->{schema} ? %{$self->{schema}} : (); + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + local => 0, + empty => 1, + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + %{$self->{schema}} = %old; + $self->{schema}; +} +END_OF_SUB + +sub load_state { +# ----------------------------------------------------------------------------- +# $obj->load_state; +# ----------------- +# Loads relation structure from def file. If you want to reload the +# structure currently stored on disk, you should call ->reload or ->reset - +# this method caches files (via GT::Config). +# + my ($self, $reload) = @_; + my $name = $self->name; + -e "$self->{connect}->{def_path}/$name.def" or return $self->fatal(FILENOEXISTS => "$self->{connect}->{def_path}/$name.def"); + $self->debug("Loading state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + (my $header = DEF_HEADER) =~ s/%TABLE_NAME%/$name/g; + $self->{schema} = GT::Config->load( + "$self->{connect}->{def_path}/$name.def" => { + cache => !($reload and $reload eq 'reload'), + chmod => 0666, + debug => $self->{_debug}, + sort_order => sub { + my ($keya, $keyb, $vala, $valb) = @_; + if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) { + return $vala->{pos} <=> $valb->{pos}; + } + else { + return $keya cmp $keyb; + } + }, + header => $header + } + ); + $self->{driver}->{schema} = $self->{schema} if $self->{driver} and exists $self->{driver}->{schema}; + $self->debug("State loaded for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + return 1; +} + +$COMPILE{reload} = __LINE__ . <<'END_OF_SUB'; +sub reload { +# ----------------------------------------------------------------------------- +# $obj->reload; +# ------------- + shift->load_state('reload'); +} +END_OF_SUB + +sub reset { +# ----------------------------------------------------------------------------- +# Works just like reload, except it always returns false, allowing for a +# shortcut such as: +# +# $code->that_changes($table) or return $table->reset; +# + shift->load_state('reload'); + return; +} + +# -------------------------------------------------------------------------------------- # +# SQL OPERATIONS # +# -------------------------------------------------------------------------------------- # + +sub add { +# ----------------------------------------------------------- +# add() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to add. +# OUT: ID number if auto_incremented table, or undef if failure +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->add(HASH or HASH_REF or CGI) only.'); + $input = {%$input}; + my $table = $self->name or return $self->fatal('NOTABLE'); + + my $c = $self->{schema}->{cols}; + my $ai = $self->{schema}->{ai}; + my $err = 0; + + my %skip_check = ( + $ai => 1 + ); + + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + $skip_check{$tree->father_id_col}++; + $skip_check{$tree->root_id_col}++; + $skip_check{$tree->depth_col}++; + } + +# Clear errors. + $self->{_error} = []; + + for my $col (keys %$c) { + my $default = $c->{$col}->{default}; + next if $skip_check{$col}; + my $set = defined $input->{$col} && $input->{$col} =~ /\S/; + +# The following code is a little inconsistent (not_null sometimes means a value +# is required, sometimes it doesn't) because it needs to be backwards +# compatible. Changing this behaviour will break a lot of code. + unless ($set) { + if ($c->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL)$/) { +# If we have a default, use it, otherwise set it to undef so that it will get +# inserted as NULL or return a NOTNULL error (see _check_value()). + if (defined $default and length $default) { + delete $input->{$col}; + } + else { + $input->{$col} = undef; + } + } + elsif ($c->{$col}->{type} =~ /^(?:CHAR|VARCHAR|.*TEXT)$/) { +# The only cases where the default is used is when we have a default and it +# hasn't been passed into add(). Otherwise, set the column to undef (to catch +# NOTNULL) or an empty string, depending on the not_null setting of the column. + if (!exists $input->{$col} and defined $default and length $default) { + delete $input->{$col}; + } + else { + $input->{$col} = $c->{$col}->{not_null} ? undef : ''; + } + } +# For all other column types just do what <=r1.256 did, except set the value to +# undef so _check_value() catches the NOTNULL instead of triggering it here so +# we don't get duplicate errors. + elsif ($c->{$col}->{not_null} and not (!exists $input->{$col} and defined $default and length $default)) { + $input->{$col} = undef; + } + } + } + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + my $sth = $self->insert($input); + return $sth ? $ai ? $sth->insert_id : 1 : undef; +} + +sub insert { +# ----------------------------------------------------------- +# $obj->insert(key1 => $value1, key2 => $value2); +# ------------------------------------------------ +# Key values pairs that correspond to the row you are +# inserting. +# +# $obj->insert(\%row); +# --------------------- +# A hash that contains key value pairs that corespond to +# the row you are inserting. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF) only.'); + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data. + keys %$opts or return $self->warn(NOVALUES => "insert()"); + +# Copy the data and remove anything that doesn't make sense here. + my $c = $self->{schema}->{cols}; + my %set = map { exists $opts->{$_} ? ($_ => $opts->{$_}) : () } keys %$c; + +# Check for file uploads. + my ($fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) { + require GT::SQL::File; + $fset = GT::SQL::File->pre_file_actions(\%fcols, \%set, $opts) or return; + } + + my $tree; + if ($self->{schema}->{tree}) { + $tree = $self->tree; + my $f = $tree->father_id_col; + my $r = $tree->root_id_col; + my $d = $tree->depth_col; + if ($set{$f}) { + my $pk = $self->{schema}->{pk}->[0]; + my ($root, $depth) = $self->select($r, $d, { $pk => $set{$f} })->fetchrow; + $set{$r} = $root || $set{$f}; + $set{$d} = $depth + 1; + } + else { + $set{$f} = $set{$r} = $set{$d} = 0; # A root record + } + } + + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_insert(\%set) or return; + } + $self->{last_insert} = \%set; + +# Weighted indexing needs special handling + my $tmp_weight; + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $tmp_weight = $self->_get_indexer->pre_add_record( $self->{last_insert} ) or return; + } + + my $sth = $self->{driver}->insert(\%set) or return; + +# If we have files, let's save them. + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + if ((my @pk = $self->pk()) == 1 and keys %fcols) { + my $key = $self->ai() ? $sth->insert_id : $set{$pk[0]}; + require GT::SQL::File; + my $tbl = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }) or return; + $tbl->add_file({ %set, %$fset }, $key) or return; + } + } + +# Finish off special handling for weighted indexing + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) { + $self->_get_indexer->post_add_record( $self->{last_insert}, $sth, $tmp_weight ) or return; + } + +# If a tree exists, insert any new entries required + if ($self->{schema}->{tree}) { + $tree->insert(insert_id => $sth->insert_id, data => \%set); + } + + return $sth; +} + +$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB'; +sub insert_multiple { +# ----------------------------------------------------------- +# $obj->insert_multiple(['key1', 'key2', 'key3'], [$value1_1, $value1_2, $value1_3], [$value2_1, $value2_2, $value2_3], ...); +# ------------------------------------------------ +# The first array ref is the columns, and all following array refs are the +# values to be inserted. +# +# This method doesn't mess around - it doesn't check to make sure all the +# columns you entered exist, nor does it do foreign key checks, nor does it +# handle raw SQL values via scalar references (it does, however, support +# undef as NULL). Currently, it does not support file columns or columns +# indexed by GT::SQL's 'INTERNAL' indexer. +# +# Returned is the number of _queries_ successfully executed, or undef if no +# queries were executed successfully. Note that the number of queries is not +# necessarily the same as the number of rows insert - in particular, several +# rows may be inserted in a single query in some databases (currently, +# MySQL). +# + my ($self, $cols, @values) = @_; + $cols or return $self->fatal(BADARGS => 'Usage: $obj->insert_multiple(ARRAY_REF, ARRAY_REF, ...) only'); + + my $table = $self->name or return $self->fatal('NOTABLE'); + + $self->{schema}->{tree} and return $self->fatal(TREENOCANDO => 'insert_multiple', $table); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Make sure we have some data, and the right number for each insert. + @values or return $self->warn(NOVALUES => "insert()"); + for my $val (@values) { + if (@$val != @$cols) { + return $self->fatal(BADMULTVALUES => 'insert_multiple()'); + } + } + + my $c = $self->{schema}->{cols}; + for (my $i = 0; $i < @$cols; $i++) { + unless (exists $c->{$cols->[$i]}) { + splice @$cols, $i, 1; + for my $val (@values) { + splice @$val, $i, 1; + } + --$i; + } + } + +# Query is executed inside to handle ai fields. + $self->{driver}->insert_multiple($cols, \@values) or return; +} +END_OF_SUB + +$COMPILE{modify} = __LINE__ . <<'END_OF_SUB'; +sub modify { +# ----------------------------------------------------------- +# modify() +# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change. +# OUT: 1 on success, undef on failure. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->modify(HASH or HASH_REF or CGI) only.'); + $input = {%$input}; + my $table = $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + + my $err; + +# Remove primary keys from update clause and make sure we have a primary key. + my $where; + for my $key (@{$self->{schema}->{pk}}) { + $where->{$key} = delete $input->{$key} if exists $input->{$key}; + } + unless (keys %{$where} == @{$self->{schema}->{pk}}) { + $self->warn('NOPKTOMOD'); + $err++; + } + +# Check to see if the record has been updated since the original record was retrieved. + $err++ unless $self->_check_timestamp($where, $input); + +# If we caught any errors, return. + if ($err and ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + + my $cols = $self->{schema}->{cols}; + for my $col (keys %$cols) { + +# update() will handle not null checks + next unless exists $input->{$col}; + +# Don't allow modification of timestamps + if ($cols->{$col}->{type} eq 'TIMESTAMP') { + delete $input->{$col}; + } +# Treat numeric and date columns set to empty strings as NULL (the update() +# will catch NOT NULL errors). Do this with date columns because '' is not a +# valid date. + elsif ($cols->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL|DATE|TIME|DATETIME)$/ and defined $input->{$col} and $input->{$col} eq '') { + $input->{$col} = undef; + } +# For add and modify, empty strings are considered as NULL, so set these values +# to undef so it triggers a NOT NULL error during the update(). + elsif ($cols->{$col}->{not_null} and not (defined $input->{$col} and length $input->{$col})) { + $input->{$col} = undef; + } + } + +# Execute the update + $self->update($input, $where) or return; + return 1; +} +END_OF_SUB + +sub update { +# ----------------------------------------------------------- +# $obj->update($hash_ref, $condition, $opts); +# ------------------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->update($hash_ref_1, $hash_ref_2, $opts); +# ---------------------------------------- +# Hash1 is what needs to be changed. +# Hash2 is the condition. +# + my $self = shift; + my ($set, $where, $opts) = @_; + ref $set eq 'HASH' or return $self->fatal(BADARGS => 'Usage: $obj->update(HASH_REF, CONDITION_OBJ or HASH_REF, HASH_REF)'); + keys %$set or return $self->fatal(BADARGS => 'update called with nothing to set!'); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Check to make sure the update is possible + $opts ||= {}; + $where ||= {}; # Update all. + + my $where_cond = $self->_build_cond($where); + +# Check to see if we have files to update. + my ($fset, %fcols); + if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) { + my @pk = $self->pk(); + if (@pk == 1) { + my @ids = $self->select($pk[0], $where_cond)->fetchall_list(); + + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $fset = $file->pre_file_actions(\%fcols, $set, $opts, \@ids) or return; + + if (not keys %$set and not keys %$fset) { + return $self->warn(BADARGS => "update called with nothing to set!"); + } + } + else { + for my $col (keys %fcols) { + delete $set->{$col}; + delete $set->{"${col}_del"}; + delete $set->{"${col}_filename"}; + } + } + } + +# If there is a tree, and the father_id is being updated, call the appropriate tree method. + my $tree_data; + if ($self->{schema}->{tree}) { + my $tree = $self->tree; + if (exists $set->{$tree->father_id_col}) { + $tree_data = $tree->pre_update(where => $where_cond, data => $set) or return; + } + } + +# Remove any invalid columns from the set (_build_set also does this, but +# _check_update uses $set) + for my $key (keys %$set) { + delete $set->{$key} unless exists $self->{schema}->{cols}->{$key}; + } + +# Validate data. + unless ($opts->{GT_SQL_SKIP_CHECK}) { + $self->_check_update($set, $where) or return; + } + my $set_cond = $self->_build_set($set); + +# If we are updating this tables primary key, then get the original +# value and save it for after the update. + my $pk = $self->{schema}->{pk}; + my $where_r = $where_cond->as_hash; + my @update_pk; + for (@$pk) { + if (defined $set->{$_} and defined $where_r->{$_} and $set->{$_} ne $where_r->{$_}) { + push @update_pk, $_; + } + } + +# Update the search index if changing a weighted column. + my $tmp_weights = {}; + my %wcols; + if ($self->{_index} and ! $opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $tmp_weights = $self->_get_indexer->pre_update_record( $set_cond, $where_cond ) or return; + last; + } + } + } + + $self->{sel_opts} ||= []; + +# Save the where clause. + $self->{last_where} = $where_cond; + +# Perform the update. + my $sth = $self->{driver}->update($set_cond, $where_cond) or return; + +# The query was successful, so now if there is a tree, call the tree's update method + if ($tree_data) { + $self->tree->update($tree_data); + } + +# Update the foreign keys of other tables if this tables primary key changed. + for my $key (@update_pk) { + for my $table (@{$self->{schema}->{fk_tables}}) { + my $new_me = $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + my $fk_hash = $new_me->{schema}->{fk}->{$self->name} or next; + for my $my_col (keys %$fk_hash) { + if ($fk_hash->{$my_col} eq $key) { + $new_me->update({ $my_col => $set->{$key} }, { $my_col => $where_r->{$key} }); + } + } + } + } + +# Update any file changes. + if (keys %fcols and $self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) { + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $File->update_records({ %$set, %$fset }, $where_cond) or return; + } + +# Update the search index if required. + if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX}) { + %wcols = $self->_weight_cols; + for my $col (keys %wcols) { + if ($wcols{$col} and exists $set->{$col}) { + $self->_get_indexer->post_update_record( $set_cond, $where_cond, $tmp_weights ) or return; + last; + } + } + } + return $sth; +} + +sub delete { +# ----------------------------------------------------------- +# $obj->delete($condition); +# -------------------------- +# $condition is a Condition or a +# hash reference. +# +# $obj->delete($val); +# ---------------------- +# Deletes a single record based on the scalar value being the +# primary key. +# +# $obj->delete([$val1, $val2]); +# -------------------------------- +# If you have a composite primary key, deletes a single record +# based on the values being the primary keys. +# +# NOTE: use delete_all to delete everything +# + my $self = shift; + @_ > 0 or return $self->fatal(BADARGS => "You must call delete_all to delete all entries"); + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; +# Clear errors. + $self->{_error} = []; + + my ($opt, $cond, $where, $do_select, %del, @rows); + +# Determine what sort of delete to do. + unless (@_ == 1) { + for my $i (0 .. $#_) { + $_ = $_[$i]; + /^abort$/ and do { $opt = splice(@_, $i, 1); last }; + /^cascade$/ and do { $opt = splice(@_, $i, 1); last }; + /^ignore$/ and do { $opt = splice(@_, $i, 1); last }; + /^cleanup$/ and do { $opt = splice(@_, $i, 1); last }; + } + } + +# Get the where clause we are going to use to do the delete. This can be +# either from a a scalar/array reference representing the primary key, or a +# condition/hash reference representing a where clause. + if ( ((ref $_[0] eq 'ARRAY') or (not ref $_[0])) and (@_ == 1) ) { + my @keys = @{$self->{schema}->{pk}}; + my @vals = ref $_[0] ? @{shift()} : shift(); + my $href = {}; + if (@keys != @vals) { + return $self->fatal(BADARGS => "Your primary key is made of " . @keys . " elements, but you passed in " . @vals . " elements."); + } + while (@vals) { + $href->{shift(@keys)} = shift(@vals); + } + (keys %{$href}) or return $self->fatal(BADARGS => 'Usage: $obj->delete(CONDITION_OBJ or PRIMARY_KEY or [PRIMARY_KEY1, PRIMARY_KEY2])'); + $where = $self->_build_cond($href); + } + else { + ($where, $do_select) = _extract_where(@_); + } + +# Make sure $where is not empty. + if (! $where->sql) { + return $self->fatal(BADARGS => "Could not create a condition object out of arguments."); + } + +# Save the where clause. + $self->{last_where} = $where; + $opt ||= 'cascade'; + +# Do a 'cascade' or 'abort' delete. + if ($opt ne 'ignore' and $opt ne 'cleanup' and @{$self->fk_tables}) { + my $sth; +# If they passed in a complex condition we select + if ($do_select) { + $sth = $self->select($where); + } +# If the hash that was passed in does not contain the foreign keys we select + elsif (not $self->_check_keys($where)) { + $sth = $self->select($where); + } + + if ($sth) { + $self->_delete_select($sth, $opt) or return + } + else { + $self->_delete_cond($where, $opt) or return + } + } + +# now handle the indexes if that's required + my $tmp_weights = {}; + if ($self->{_index} and $self->_weight_cols) { + $tmp_weights = $self->_get_indexer()->pre_delete_record( $where ) or return; + } + +# delete anything related to tables + if ($self->{_file} and $self->_file_cols() ) { + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + $file->delete_records( $where ); + } + +# For many to one fk relations + my $rows; + if ($opt eq 'cleanup') { + defined($rows = $self->_delete_cleanup($where)) or return; + } + else { +# Get the SQL. + my $sth = $self->{driver}->delete($where) or return; + $rows = $sth->rows; + } + + if ($self->{_index} and $self->_weight_cols) { + $self->_get_indexer()->post_delete_record( $where, $tmp_weights ) or return; + } + + defined $rows or return; + return ($rows == 0) ? "0E0" : $rows; +} + +$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB'; +sub delete_all { +# ----------------------------------------------------------- +# $obj->delete_all; +# ----------------- +# Deletes all the records in the current table. +# + my ($self, $opt, $done) = @_; # $done is used internally + $opt ||= 'cascade'; + my $name = $self->name or return $self->fatal('NOTABLE'); + $done ||= { $name => 1 }; + +# Connect to the database if we are not already connected + $self->connect or return; + +# Clear errors. + $self->{_error} = []; + +# Do the cascading delete. + for my $fktable (@{$self->fk_tables}) { + next if $done->{$fktable}++; + my $new_me = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + if ($opt eq 'cascade') { + $done->{$fktable}++; + $new_me->delete_all($opt, $done) or return; + } + else { + $new_me->count and return $self->warn(DEPENDENCY => $fktable); + } + } + my $tmp_weights = {}; + if ($self->_weight_cols()) { $tmp_weights = $self->_get_indexer()->pre_delete_all_records() or return } + my $sth = $self->{driver}->delete() or return; + if ($self->_weight_cols()) { $self->_get_indexer()->post_delete_all_records($tmp_weights) or return } + + $sth; +} +END_OF_SUB + +$COMPILE{query} = __LINE__ . <<'END_OF_SUB'; +sub query { +# ------------------------------------------------------------------- +# Just performs the query and returns a fetchall. +# + return shift->_query(@_)->fetchall_arrayref; +} +END_OF_SUB + +$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB'; +sub query_sth { +# ------------------------------------------------------------------- +# Just performs the query and returns an active sth. +# + return shift->_query(@_); +} +END_OF_SUB + +$COMPILE{_query} = __LINE__ . <<'END_OF_SUB'; +sub _query { +# ------------------------------------------------------------------- +# Parses the input, and runs a select based on input. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => 'Usage: $obj->insert(HASH or HASH_REF or CGI) only.'); + $self->name or return $self->fatal('NOTABLE'); +# Clear errors. + $self->{_error} = []; + +# Strip out values that are empty or blank (as query is generally derived from +# cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts; + $opts = \%input; + +# If build_query_cond returns a GT::SQL::Search object, then we are done. + my $cond = $self->build_query_cond($opts, $self->{schema}->{cols}); + + if ( ( ref $cond ) =~ /(?:DBI::st|::STH)$/i ) { + return $cond; + } + +# If we have a callback, then we get all the results as a hash, send them +# to the callback, and then do the regular query on the remaining set. + if (defined $opts->{callback} and (ref $opts->{callback} eq 'CODE')) { + my $pk = $self->{schema}->{pk}->[0]; + my $sth = $self->select($pk, $cond) or return; + my %res = map { $_ => 1 } $sth->fetchall_list; + my $new_results = $opts->{callback}->($self, \%res); + $cond = GT::SQL::Condition->new($pk, 'IN', [keys %$new_results]); + } + +# Set the limit clause, defaults to 25, set to -1 for none. + my $in = $self->_get_search_opts($opts); + my $offset = ($in->{nh} - 1) * $in->{mh}; + $self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb}); + $self->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1; + +# Now do the select. + my @sel = (); + if ($cond) { push @sel, $cond } + if ($opts->{rs} and $cond) { push @sel, $opts->{rs} } + my $sth = $self->select(@sel) or return; + + return $sth; +} +END_OF_SUB + +sub select_options { +# ----------------------------------------------------------- +# $obj->select_options(@options); +# -------------------------------- +# @options should be a list of options you want append to your search. +# Select options will be used for delete, and select. +# + my $self = shift; + push @{$self->{sel_opts}}, @_ if @_; + wantarray ? @{$self->{sel_opts}} : $self->{sel_opts}; +} + +sub select { +# ----------------------------------------------------------- +# $obj->select; +# ------------- +# returns all rows from that relation (no where condition). +# +# $obj->select($condition, \@select_returns); +# -------------------------------------------- +# $condition is a Condition or a hash reference. +# +# $obj->select(\%columns, \@select_returns); +# ------------------------------------------- +# $col1 = $val1, $col2 = $val2 +# +# @select_returns is a list of the fields that you wish returned. If none are +# specified all fields will be returned. +# + my $self = shift; + my $sel_opts = $self->{sel_opts} || []; + $self->{sel_opts} = []; + $self->name or return $self->fatal('NOTABLE'); + +# Connect to the database if we are not already connected + $self->connect or return; + +# Get the list of select fields. + my (@fields); + for (@_) { + if (ref $_ eq 'ARRAY') { push @fields, @{$_} } + elsif (not ref $_) { push @fields, $_ } + } + @fields = grep defined && length, @fields; +# Extract the where clause and save it for future. + my ($where, $do_select) = _extract_where(@_); + $self->{last_where} = $where; + +# Perform the select + my $sth = $self->{driver}->select(\@fields, $where, $sel_opts) or return; + + $self->{last_hits} = undef; + my $rows = $sth->rows; + +# Attempt to optimize a possible later call to hits(). If there was no limit, +# it's the number of rows. If there was a limit, and the rows returned was +# less than the limit (but still greater than 0), we can calculate it. + $sel_opts = join " ", @$sel_opts; + if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) { + my ($limit, $offset); + if (defined $3) { # MySQL-style, with an offset + ($offset, $limit) = ($1, $3); + } + elsif (defined $4) { # Pg-style with OFFSET before LIMIT + ($offset, $limit) = ($4, $5); + } + else { + ($limit, $offset) = ($1, $2 || 0); + } + if ($rows > 0 and $rows < $limit) { + $self->{last_hits} = $offset + $rows; + } + } + else { + $self->{last_hits} = $rows; + } + return $sth; +} + +$COMPILE{get} = __LINE__ . <<'END_OF_SUB'; +sub get { +# ----------------------------------------------------------- +# get() +# IN : primary key and format options, and fields wanted. +# OUT: array_ref/hash_ref on success, undef on failure. +# + my $self = shift; + +# Connect to the database if we are not already connected + $self->connect or return; + + my (@keys, @pk, @sel, $cond, $method, $format, $cols); + $self->name or return $self->fatal('NOTABLE'); + $cond = GT::SQL::Condition->new; + + if (@_ == 0) { return $self->fatal(BADARGS => 'Usage: $obj->get(HASH or HASH_REF or CGI_OBJ)') } + elsif (ref $_[0] eq 'HASH') { + my $href = shift; + for (keys %{$href}) { + $cond->add($_, '=', $href->{$_}); + } + } + else { + @keys = ref $_[0] eq 'ARRAY' ? @{shift()} : (shift); + @pk = @{$self->{schema}->{pk}}; + while (@keys) { + $cond->add(shift(@pk), '=', shift(@keys)); + } + } + + $format = uc shift || 'HASH'; + $cols = shift || []; + $method = $format eq 'ARRAY' ? 'fetchrow_arrayref' : 'fetchrow_hashref'; + my $sth = $self->select($cond, $cols); + if ($sth) { + return $sth->$method(); + } + else { + return; + } +} +END_OF_SUB + +sub do_query { +# ----------------------------------------------------------- +# $obj->do_query($query) +# $obj->do_query($query, \@args); +# ------------------------ +# Performs SQL $query and returns a +# Query object as the result of this query. +# + my ($self, $query, $args) = @_; + + $self->connect or return; + $query = $self unless (ref $self || $query); + +# Show the query if debug is on. + $self->debug("Query: $query\n") if $self->{_debug} > 1; + +# Do the query. + my $sth = $self->{driver}->prepare($query) or return; + if ($args and ref $args eq 'ARRAY') { + $sth->execute(@$args) or return; + } + else { + $sth->execute or return; + } + $self->{sel_opts} = []; + return $sth; +} + +$COMPILE{do} = __LINE__ . <<'END_OF_SUB'; +sub do { + my $self = shift; + return $self->do_query(@_); +} +END_OF_SUB + +$COMPILE{reindex} = __LINE__ . <<'END_OF_SUB'; +sub reindex { +# ----------------------------------------------------------- +# $obj->reindex() +# ----------------------------------- +# Reindexes the database if required +# + my $self = shift; + my $opts = shift; + + $self->connect or return; + my $Indexer = $self->_get_indexer(); + $Indexer->reindex_all( $self, $opts ); +} +END_OF_SUB + +$COMPILE{indexing} = __LINE__ . <<'END_OF_SUB'; +sub indexing { +# ----------------------------------------------------------- +# $obj->indexing(0/1); +# -------------------- +# Enables/Disables indexing, spans life of object. +# + @_ == 2 and ($_[0]->{_index} = $_[1]); + return $_[0]->{_index}; +} +END_OF_SUB + +$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB'; +sub prepare { +# ----------------------------------------------------------- +# Passes query straight through to dbh. +# + my ($self, $query) = @_; + $self->connect or return; + return $self->{driver}->prepare($query); +} +END_OF_SUB + +sub name { +# ----------------------------------------------------------- +# $obj->name; +# ----------- +# Returns the name of the current table instance. +# +# $obj->name($table_name); +# ------------------------- +# Sets the name for the table to create. +# + my $self = shift; + if (defined $_[0]) { + my $name = shift; + my $prefix = $self->{connect}->{PREFIX}; + if (length $prefix) { + unless ($name =~ /^$prefix/) { + $name = $prefix . $name; + } + } + unless ($name =~ /^(\w+)$/) { + return $self->fatal(BADNAME => $name); + } + $self->{name} = $1; + + # If a schema exists, a new GT::Config object is needed as the name just changed + $self->_new_schema if $self->{schema}; + } + return $self->{name}; +} + +# -------------------------------------------------------------------------------------- # +# ACCESSOR METHODS # +# -------------------------------------------------------------------------------------- # + +$COMPILE{cols} = __LINE__ . <<'END_OF_SUB'; +sub cols { +# ----------------------------------------------------------- +# $obj->cols; +# ----------- +# Returns the hash structure for this tables +# cols. +# +# $obj->cols($hash_ref); +# ---------------------- +# Sets the relations columns as specified by $hash_ref. +# the hash should look like { $col_name => { type => 'int' } }. +# +# $obj->cols($array_ref); +# ----------------------- +# Just like $hash_ref, except an array ref. The array should look like: +# [ $col_name => { type => 'int' } ]. The difference between this and +# using a hash reference is that with the array ref pos will be automatically +# calculated and set in each column definition. The following two lines passed +# to cols() are equivelant and internally become the same thing: +# +# { $col1 => { type => 'int', pos => 1 }, $col2 => { type => 'text', pos => 2 } } +# [ $col1 => { type => 'int' }, $col2 => { type => 'text' } ] +# +# $obj->cols( +# $col1 => { +# type => 'int', +# not_null => 1 +# }, +# $col2 => { ... } +# ); +# ---------------------- +# Sets the relations columns as specified via method +# params. +# + my $self = shift; + + if (@_) { + if (@_== 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{cols} = $arg; + } + elsif (ref $arg eq 'ARRAY' and not @$arg % 2) { + for (0 .. 0.5 * @$arg - 1) { + $arg->[2 * $_ + 1]->{pos} = $_ + 1; + } + $self->{schema}->{cols} = {@$arg}; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->cols(HASH_REF or ARRAY_REF or HASH)'); + } + } + elsif (not @_ % 2) { $self->{schema}->{cols} = {@_} } + else { return $self->fatal(BADARGS => 'Usage $obj->cols(HASH_REF or ARRAY_REF or HASH)') } + + my $name = $self->{name}; + for (keys %{$self->{schema}->{cols}}) { + ref $self->{schema}->{cols}->{$_} eq 'HASH' or return $self->fatal(BADARGS => 'You must have a hash of hashes to specify your columns'); + exists $self->{schema}->{cols}->{$_}->{type} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no type defined."); + exists $self->{schema}->{cols}->{$_}->{pos} or return $self->fatal(BADARGS => "Error in table '$name' with column '$_': no position defined."); + } + } + + return $self->{schema}->{cols} unless wantarray; + +# Wantarray has been set so create a copy of the cols whose +# first and second level references can be clobbered. +# This assumes that the values side of the schema will +# always been hashrefs + my %cols_copy = %{$self->{schema}{cols}}; + for my $col_name (keys %cols_copy) { + + my %col_data = %{$cols_copy{$col_name}}; + $cols_copy{$col_name} = \%col_data; + + for (keys %col_data) { + if (ref $col_data{$_} eq 'HASH') { + $col_data{$_} = {%{$col_data{$_}}}; + } + elsif (ref $col_data{$_} eq 'ARRAY') { + $col_data{$_} = [@{$col_data{$_}}]; + } + } + } + + return %cols_copy; +} +END_OF_SUB + +$COMPILE{pk} = __LINE__ . <<'END_OF_SUB'; +sub pk { +# ----------------------------------------------------------- +# $obj->pk; +# --------- +# Returns the primary key columns for the current table. In scalar context, +# returns undef to indicate no primary key, or an array reference of column +# names. In list context you get a list of column names, or an empty list if +# no primary key exists. +# +# $obj->pk($array_ref); +# ---------------------- +# Sets relation primary key, $array_ref is the reference to an array which +# looks like: +# ["FIELD1", ..., "FIELDN"] +# +# $obj->pk($field1, $field2, ...); +# --------------------------------- +# Sets relation primary key given the fields which are in parameter. +# + my $self = shift; + my @pk; + if (@_ == 0) { + my @pk = @{$self->{schema}->{pk}}; + return wantarray ? @pk : @pk ? \@pk : undef; + } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + push @pk, @{$arg}; + } + elsif (not ref $arg) { + push @pk, $arg; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in $arg"); + } + } + else { + for (@_) { + if (not ref $_) { + push @pk, @_; + } + else { + return $self->fatal(BADARGS => "Argument to ->pk must be an array ref or a list of scalars. You passed in @_"); + } + } + } + @{$self->{schema}->{pk}} = @pk; + return wantarray ? @{$self->{schema}->{pk}} : $self->{schema}->{pk}; +} +END_OF_SUB + +$COMPILE{ai} = __LINE__ . <<'END_OF_SUB'; +sub ai { +# ----------------------------------------------------------- +# $obj->ai; +# --------- +# Returns the auto incriment column for the current +# table instance. +# +# $obj->ai($column); +# ------------------- +# Sets the AUTO INCREMENT column. +# + my ($self, $ai) = @_; + ref $ai and return $self->fatal(BADARGS => "Argument to ->ai cannot be a reference"); + $self->{schema}->{ai} = $ai if defined $ai; + return $self->{schema}->{ai} +} +END_OF_SUB + +$COMPILE{search_driver} = __LINE__ . <<'END_OF_SUB'; +sub search_driver { +# ----------------------------------------------------------- +# $obj->search_driver; +# -------------------- +# Returns the search driver column for the current +# table instance. +# +# can be 'INTERNAL', 'MYSQL', 'NONINDEXED' +# +# $obj->search_driver($column); +# ----------------------------- +# Sets the Searching Driver column. +# + my ($self, $search_driver) = @_; + $search_driver and ref $search_driver and return $self->fatal(BADARGS => "Argument to ->search_driver must not be a reference"); + $self->{schema}->{search_driver} = $search_driver if $search_driver; + if ( not defined $self->{schema}->{search_driver} ) { + my $indexer = $self->_get_indexer(1); + ( ref $indexer ) =~ /::(\w+)::Indexer$/; + $self->{schema}->{search_driver} = $1; + } + return $self->{schema}->{search_driver}; +} +END_OF_SUB + +$COMPILE{index} = __LINE__ . <<'END_OF_SUB'; +sub index { +# ----------------------------------------------------------- +# $obj->index; +# ------------ +# Returns a hash in list context and a hash ref +# in scalar context. This hash contain the index +# name as the keys and an array ref as the values. +# The array ref contains the fields that are part of +# the index that is the key. +# +# $obj->index($index_name, $col1, ..., $coln); +# ------------------------------------------------- +# Sets an index called $index_name handling $col1, +# ..., $coln. +# +# $obj->index({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets indexes for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{index} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->index(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->index(HASH_REF) or $obj->index') + } + } + else { + my $index_name = shift; + $self->{schema}->{index}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{index}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{index}}) { + ref $self->{schema}->{index}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index}; +} +END_OF_SUB + +sub subclass { +# ----------------------------------------------------------- +# $obj->subclass; +# --------------- +# Returns the subclass for the current table. +# This subclass is what the objects are blessed +# into. This makes it easy to subclass per table object. +# +# $obj->subclass($subclass); +# --------------------------- +# Sets the subclass. $subclass should be a hash +# reference or a hash. +# + my $self = shift; + my $opt; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{subclass}} : $self->{schema}->{subclass} } + elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift } + elsif (defined $_[0] and @_ % 2 == 0) { $opt = {@_} } + else { return $self->fatal(BADARGS => 'Usage: $obj->subclass(HASH or HASH_REF)') } + + for my $meth (qw/html relation table/) { + next unless exists $opt->{$meth}; + if (ref $opt->{$meth} ne 'HASH') { + return $self->fatal(BADARGS => 'The hash that is passed into subclass() must be a hash of hashes'); + } + my $val = {}; + my $prefix = $self->{connect}->{PREFIX}; + for (keys %{$opt->{$meth}}) { + my $v = $_; + if (length $prefix) { + unless (/^$prefix/) { + $v = $prefix . $v; + } + } + $val->{$meth}->{$v} = $opt->{$meth}->{$_}; + } + $self->{schema}->{subclass}->{$meth} = $val->{$meth}; + } + return 1; +} + +sub unique { +# ----------------------------------------------------------- +# $obj->unique; +# ------------- +# Returns a hash in list context and a hash ref +# in scalar context. This hash contains the unique +# index names as the keys and array refs as the values. +# The array refs contain the fields that are part of +# the unique index. +# +# $obj->unique($index_name, $col1, ..., $coln); +# --------------------------------------------- +# Sets an unique index called $index_name handling $col1, +# ..., $coln. +# +# $obj->unique({ +# $index1 => [field1, field2], +# $index2 => [field3, field4] +# }); +# -------------------------------- +# Sets uniques for this table specified by the key +# with the values as the fields. +# + my $self = shift; + if (@_ == 0) { return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique} } + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + $self->{schema}->{unique} = $arg; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->unique(INDEX_NAME, FIELD1, FIELD2 ...) or $obj->unique(HASH_REF) or $obj->unique') + } + } + else { + my $index_name = shift; + $self->{schema}->{unique}->{$index_name} = []; + while (@_) { + my $arg = shift || last; + push @{$self->{schema}->{unique}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg]; + } + } + + for (keys %{$self->{schema}->{unique}}) { + ref $self->{schema}->{unique}->{$_} eq 'ARRAY' or return $self->fatal(BADARGS => "Index columns must be in the form of an array reference"); + } + + return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique}; +} + +$COMPILE{fk} = __LINE__ . <<'END_OF_SUB'; +sub fk { +# ----------------------------------------------------------- +# $obj->fk; +# --------- +# Returns a hash in list content and a hash ref in scalar +# context. This hash ref contains the foreign table as the +# key and a hash ref as the value. The hash ref has keys as +# the field in the current table that relates to fields in +# the foreign table. The values are the fields in the foreign +# table that the fields in this table relate to. +# +# $obj->fk({ +# RELATION_NAME => { +# SOURCE_FIELD_1 => TARGET_FIELD_2, +# ... +# SOURCE_FIELD_n => TARGET_FIELD_n +# } +# }); +# ---------------------------------------------------------- +# You can set all the relations for the tables this way. +# sets the source and target schemas for the given relation +# name. Source and target schemas shall have the same type ! +# +# $obj->fk(RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD }); +# ------------------------------------------------------------------ +# Sets the foreign key relations for one relation. +# +# this structure introduces a limitations: a table cannot +# refer two schemas in the same target table, which should +# really not be a problem. +# + my $self = shift; + @_ or return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; + + my %set; + if (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'HASH') { + %set = %$arg; + } + else { + return $self->{schema}->{fk}->{$arg}; + } + } + elsif (@_ == 2 and ref $_[1] eq 'HASH') { + %set = @_; + } + else { + return $self->fatal(BADARGS => 'Usage: $obj->fk(TABLE_NAME, HASH_REF or HASH_REF) or $obj->fk'); + } + my $prefix = $self->{connect}->{PREFIX}; + for my $table (keys %set) { + my $prefixed = $table; + $prefixed = $prefix . $prefixed if length $prefix and $table !~ /^\Q$prefix/; + $self->{schema}->{fk}->{$prefixed} = $set{$table}; + } + +# Make sure the arguments passed in were correct. + for my $ftable (keys %{$self->{schema}->{fk}}) { + ref $self->{schema}->{fk}->{$ftable} eq 'HASH' or return $self->fatal(BADARGS => "fk must contain a hash of hashes"); + } + + $self->_update_fk_tables or return; + + return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk}; +} +END_OF_SUB + +$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub fk_tables { +# ----------------------------------------------------------- +# Used to set the tables that reference this one. +# + my $self = shift; + if (@_ == 0) { return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables} } + elsif (@_ == 1) { + my $arg = shift; + if (ref $arg eq 'ARRAY') { + $self->{schema}->{fk_tables} = [@$arg]; + } + else { + @{$self->{schema}->{fk_tables}} = ($arg); + } + } + else { + @{$self->{schema}->{fk_tables}} = @_; + } + for (@{$self->{schema}->{fk_tables}}) { + if (ref $_) { + return $self->fatal(BADARGS => "Arguments to fk_table must be scalars"); + } + } + my $prefix = $self->{connect}->{PREFIX}; + for (@{$self->{schema}->{fk_tables}}) { + if (length $prefix) { + unless (/^$prefix/) { + $_ = $prefix . $_; + } + } + } + return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables}; +} +END_OF_SUB + +$COMPILE{tree} = __LINE__ . <<'END_OF_SUB'; +sub tree { +# ----------------------------------------------------------- +# An accessor for the GT::SQL::Tree object associated with +# this table. Creating/dropping a tree is done through the +# table editor. If no tree exists, you get undef and a warning +# occurs. + my $self = shift; + return $self->warn(NOTREE => $self->name()) unless ($self->{schema}->{tree}); + if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"}) { + $self->debug("Returning GT::SQL::Tree object for table $self->{name} from cache") if $self->{_debug}; + return $cached; + } + + require GT::SQL::Tree; + $self->debug("Creating new GT::SQL::Tree object for table " . $self->name()) if $self->{_debug}; + my $tree = GT::SQL::Tree->new({ + table => $self, + debug => $self->{_debug} + }); + + if ($self->{connect}->{obj_cache}) { + $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"} = $tree; + } + + return $tree; +} +END_OF_SUB + +$COMPILE{check_schema} = __LINE__ . <<'END_OF_SUB'; +sub check_schema { +# ----------------------------------------------------------- +# Checks the current table schema for inconsistencies in the +# structure. +# + my $self = shift; + my %cols = %{$self->{schema}->{cols}}; + +# Go through each column and check them + for my $col (keys %cols) { +# Make sure we have a position field. + if (! exists $cols{$col}->{pos}) { + $self->debug("Trying to create a column that does not have a position field.") if $self->{_debug}; + return $self->fatal(NOPOS => $col); + } + +# Primary key cannot be a "text" or "blob" type and must be "not null". + if ($self->_is_pk($col)) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("Trying to use a primary key without making it not null. Adding not_null to $col") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(PKTEXT => $col); + } + } + +# Unique must be "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{unique}}) { + if (grep /^\Q$col\E$/, @{$self->{unique}->{$_}}) { + unless ($self->{schema}->{cols}->{$col}->{not_null}) { + $self->debug("unique key $col is not NOT_NULL. Adding to NOT_NULL") if ($self->{_debug}); + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(UNIQTEXT => $col); + } + } + } + +# Index must ne "not null" and cannot be a "text" or "blob" type. + for (keys %{$self->{schema}->{index}}) { + if (grep /^\Q$col\E$/, @{$self->{schema}->{index}->{$_}}) { + unless ($self->_is_not_null($col)) { + $self->debug("index key $col is not NOT_NULL. Adding to NOT_NULL") if $self->{_debug}; + $self->{schema}->{cols}->{$col}->{not_null} = 1; + } + if ($cols{$col}->{type} =~ /TEXT|BLOB/i) { + return $self->fatal(INDXQTEXT => $col) if $self->{_debug}; + } + } + } + +# Autoincrement must be an "INT" type and must be the only "PRIMARY KEY" + $self->{schema}->{ai} ||= ''; + if ($col eq $self->{schema}->{ai}) { + if ($cols{$col}->{type} !~ /INT/i) { + return $self->fatal(AINOTPK => $col); + } + if (!$self->_is_pk($col) or @{$self->{schema}->{pk}} > 1) { + $self->debug("AUTO_INCREMENT column $col specified but is not the primary key. Making $col primary key.") if $self->{_debug}; + @{$self->{schema}->{pk}} = ($col); + } + } + +# File columns must point to exisiting directories where we have write access! + if ($cols{$col}->{form_type} and uc $cols{$col}->{form_type} eq 'FILE') { + $cols{$col}->{file_save_in} or return $self->fatal(NOFILESAVEIN => $col); + return $self->fatal(NODIRPRIV => $cols{$col}->{file_save_in}) + unless -w $cols{$col}->{file_save_in}; + } + } + +# Circularity check + $self->_circularity_check or return undef; + + return 1; +} +END_OF_SUB + +$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB'; +sub ordered_columns { +# ----------------------------------------------------------- +# $obj->ordered_columns; +# ---------------------- +# Returns the current table columns ordered +# in function of the "pos" type of a given +# column. +# +# The columns having no specified pos are +# appended in lexicographical order at the +# end of the result array. +# + my $self = shift; + my @cols = (); + my @append = (); + my $cols = $self->{schema}->{cols}; + for my $col (sort { + $cols->{$a}->{pos} && $cols->{$b}->{pos} ? $cols->{$a}->{pos} <=> $cols->{$b}->{pos} : + $cols->{$a}->{pos} && !$cols->{$b}->{pos} ? -1 : + $cols->{$b}->{pos} && !$cols->{$a}->{pos} ? 1 : + ($a cmp $b) + } keys %{$cols}) { + push @cols, $col; + } + + return @cols; +} +END_OF_SUB + +$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB'; +sub all_indexes { +# ----------------------------------------------------------- +# $obj->all_indexes; +# ------------------ +# Returns an array reference with all the array refs +# from the indexes and the uniques. +# + my $self = shift; + my @keys = map { @$_ } values %{$self->unique}, values %{$self->index}; + return wantarray ? @keys : \@keys; +} +END_OF_SUB + +$COMPILE{save_def} = __LINE__ . <<'END_OF_SUB'; +sub save_def { shift->save_state(@_) } +END_OF_SUB + +$COMPILE{save_state} = __LINE__ . <<'END_OF_SUB'; +sub save_state { +# ----------------------------------------------------------- +# $obj->save_state; +# ---------------------------- +# Saves table structure in $self->{connect}->{def_path}/table.def, and +# deletes the table from the object cache. +# + my $self = shift; + $self->debug("Saving state for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + $self->{schema}->save(); + $self->debug("State saved for " . $self->name) if $self->{_debug} and $self->{_debug} > 1; + + my $cache_key = join("\0", 'TABLE', $self->{name}, $self->{connect}->{def_path}); + delete $GT::SQL::OBJ_CACHE{$cache_key}; + + return 1; +} +END_OF_SUB + +$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB'; +sub file_info { +# ------------------------------------------------------------------- +# $obj->file('ColumnName', $primary_key); +# ------------------------------ +# Returns the file associated with the column +# + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->file_info(@_); +} +END_OF_SUB + +$COMPILE{file_rescan} = __LINE__ . <<'END_OF_SUB'; +sub file_rescan { +# ------------------------------------------------------------------- + my $self = shift; + require GT::SQL::File; + my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }); + return $File->rescan(); +} +END_OF_SUB + +sub check_values { +# ------------------------------------------------------------------- +# Checks to see that the values for an insert are legal to +# be inserted. Returns false on error true on success +# + my ($self, $set) = @_; + +# Check to ensure the values are valid + my %cols = %{$self->{schema}->{cols}}; + my $ai = $self->{schema}->{ai}; + for my $col (keys %$set) { + next if ($ai and $ai eq $col); + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join $GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}; + } + $self->_check_value($col, $cols{$col}, $set->{$col}); + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +# -------------------------------------------------------------------------------------- # +# PRIVATE FUNCTIONS # +# -------------------------------------------------------------------------------------- # +$COMPILE{_update_fk_tables} = __LINE__ . <<'END_OF_SUB'; +sub _update_fk_tables { +# ------------------------------------------------------------------- +# Updates all the tables fields that +# this tables is referenced by. +# + my $self = shift; + for my $table (keys %{$self->{schema}->{fk}}) { + my $foreign_table = $table eq $self->{name} + ? $self + : ($self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error)); + $foreign_table->_add_fk_table($self->{name}) + and $foreign_table->save_state(); + } + return 1; +} +END_OF_SUB + +$COMPILE{_add_fk_table} = __LINE__ . <<'END_OF_SUB'; +sub _add_fk_table { +# ----------------------------------------------------------------------------- +# Takes a foreign table name. The foreign table is added if it doesn't already +# exist in $self's fk_tables schema. Any duplicates are removed. This is to +# prevent the same table appearing several times in fk_tables. You still need +# to ->save_state() after calling this. Returns 1 if anything changed, undef +# otherwise. +# + my ($self, $add) = @_; + my %have = map { $_ => 1 } @{$self->{schema}->{fk_tables}}; + push @{$self->{schema}->{fk_tables}}, $add unless $have{$add}; + return $have{$add} ? undef : 1; +} +END_OF_SUB + +$COMPILE{_circularity_check} = __LINE__ . <<'END_OF_SUB'; +sub _circularity_check { +# ------------------------------------------------------------------- +# This function loops through all the tables in the current +# databases. If a circular reference is detected, then a +# warning is printed and FALSE is returned. If no circular +# references are detected, TRUE is returned. +# + my $self = shift; + my (%cols, @tables, %tables); + + return 1 unless keys %{$self->{schema}->{fk}}; # If there are no foreign keys there is nothing to do. + + my $name = $self->name; + + @tables = $name; + $tables{$name}++; + + for (my $i = 0; $i < @tables; $i++) { + return $self->fatal('CIRCULARLIMIT') if $i >= 100; + + my $table = $tables[$i]; + my $new = ($table eq $name) ? $self : $self->new_table($table) or return $self->fatal(FKNOTABLE => $table, $GT::SQL::error); + for my $table_name (keys %{$new->{schema}->{fk}}) { + my %this; # Allows for multiple fk's from the same table to the same key + for my $column (keys %{$new->{schema}->{fk}->{$table_name}}) { + my $tc = "$table: $table_name.$new->{schema}->{fk}->{$table_name}->{$column}"; + $self->debug("Found foreign key in $tc") if $self->{_debug}; + if (not $this{$tc}++ and $cols{$tc}++) { + $self->debug("$tc was already found!") if $self->{_debug}; + return $self->warn(CIRCULAR => $tc); + } + splice @tables, $i + 1, 0, $table_name unless $tables{$table_name}++; + } + } + } + + return 1; +} +END_OF_SUB + + +$COMPILE{_check_timestamp} = __LINE__ . <<'END_OF_SUB'; +sub _check_timestamp { +# ------------------------------------------------------------------- +# Won't modify a record if the passed in timestamp is older than +# what's in the database. +# + my ($self, $keys, $set) = @_; + +# first check to see if we even need to look up the orig timestamp. + my $auto = $self->time_check; + return 1 unless ($auto); + my $found = 0; + for (keys %$auto) { + exists $set->{$_} and ($found = 1); # should only be one timestamp. + } + return 1 unless ($found); + +# if we got here, then we do a search on the record and compare timestamp. + my $pk = $self->{schema}->{pk}; + my $cond = GT::SQL::Condition->new; + my @res; + for my $key (@$pk) { + $cond->add($key, "=", $keys->{$key}); + } + for my $tmstmp (keys %$auto) { + push @res, $tmstmp; + $cond->add($tmstmp, ">", $set->{$tmstmp}); + delete $set->{$tmstmp}; + } + my $sth = $self->select($cond, \@res) or return; + if ($sth->fetchrow_arrayref) { + return $self->warn('ALREADYCHANGED'); + } + else { + return 1; + } +} +END_OF_SUB + +sub _check_insert { +# ------------------------------------------------------------------- +# Check to make sure an insert is properly set up. +# + my ($self, $set, $cond) = @_; + my @indexes; + my %indx_hash = $self->unique; + push @indexes, values %indx_hash if (keys %indx_hash); + +# Add the primary key to the list of uniques + if (@{$self->{schema}->{pk}} and ! $self->{schema}->{ai}) { + push @indexes, $self->{schema}->{pk}; + } + +# Check that columns that aren't in the insert are not not_null columns. This +# check is done here rather than in _check_value() because _check_value() is +# also used by update(). _check_value() will handle all other not_null cases. + while (my ($c, $col) = each %{$self->{schema}->{cols}}) { + next if exists $set->{$c}; + my $default = $col->{default}; + if ($col->{not_null} and # Only check for not_null columns + (not $self->{schema}->{ai} or $c ne $self->{schema}->{ai}) and # But not the auto-increment field + (not defined $default or $default eq '')) { # And only when there isn't a default + $self->warn(NOTNULL => $col->{form_display} || $c); + } + } + +# Check that the unique columns are really unique. + my $check = {}; + INDEX: for my $index (@indexes) { + my $check = {}; + COL: for my $col (@$index) { + next INDEX if ($col eq $self->{schema}->{ai}); + $check->{$col} = $set->{$col}; + } + my $rows = $self->count($check); + if ($rows) { + $self->warn(UNIQUE => join(",", map $self->{schema}->{cols}->{$_}->{form_display} || $_, keys %$check), join(",", values %$check)); + } + } +# Check the values to make sure they are ok. + $self->check_values($set); + +# Join the list of errors. + my @errors = (ref($self->{_error}) and @{$self->{_error}}) ? @{$self->{_error}} : (); + if (@errors) { + $GT::SQL::error = join "\n", @errors; + return; + } + return 1; +} + +sub _check_update { +# ------------------------------------------------------------------- +# Checks to see if any of the set options +# are unique. If they are does a select +# on the table. If the condition tests +# true returns undef. The error will be set in +# the package error variable. +# + my ($self, $set, $cond) = @_; + +# Turn off warning here (too much work to remove unitialized values from +# returned data). + local $^W = 0; + +# Ensure that columns that are NOT NULL have not been specified as null + my %cols = %{$self->{schema}->{cols}}; + for my $col (keys %{$set}) { + if (ref $set->{$col} eq 'ARRAY') { + require GT::SQL::Display::HTML; + $set->{$col} = join($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}}); + } + $self->_check_value($col, $cols{$col}, $set->{$col}) or return; + } + my %indx_hash = $self->unique; + my @indexes = values %indx_hash; + +# Add the primary key to the list of uniques + my $pk = $self->{schema}->{pk}; + $pk = ref $pk ? $pk : [$pk]; + push @indexes, $pk unless $self->{schema}->{ai}; + +# If there are no uniques, then return previous errors, or return 1. + if (! @indexes) { + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } + } +# If the update isn't changing any unique columns, then there's no need to +# perform the select later in the code. + else { + my $updates_unique; + INDEX: for my $index (@indexes) { + for (@$index) { + if (exists $set->{$_}) { + $updates_unique = 1; + last INDEX; + } + } + } + return 1 unless $updates_unique; + } + +# Only request what has changed plus the primary key and any uniques + my %changes = (); + for (keys %$set) { $changes{$_} = 1 } + for (@$pk) { $changes{$_} = 1 } + for my $index (@indexes) { + for (@$index) { + $changes{$_} = 1; + } + } + +# Fetch records to make sure we don't break a unique clause. + my $sth = $self->select(keys(%changes), $cond) or return; + my @marked = (); + RECORD: while (my $rec = $sth->fetchrow_hashref) { + +# Go through all the indexes for this table + for my $i (0 .. $#indexes) { + +# A hash to build the count query out of + my $count_check = {}; + +# If the record is different than the one in the database + my $match = 0; + for (@{$indexes[$i]}) { + if (defined $set->{$_} and $set->{$_} ne $rec->{$_}) { + $match = 1; + } + $count_check->{$_} = $set->{$_}; + } + +# It was not different so we continue to the next set of uniques + $match or next; + +# It was different so we need to make a count select to see if it is possible +# to do this insert + if ($self->count($count_check)) { + +# the count returned true so there was a duplicate record + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# The count returned false so there was not a duplicate record +# so if the record is already marked we return false + if ($marked[$i]) { + $self->warn(UNIQUE => join(',' => map $set->{$_}, @{$indexes[$i]}), join(',' => @{$indexes[$i]})); + last RECORD; + } + else { +# else we mark the record. + $marked[$i] = 1; + } + } + } + } + +# Everything should have went fine so return true the record is +# insertable. + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + else { + return 1; + } +} + +sub _check_value { +# ------------------------------------------------------------------- +# Checks to see if a value is valid. +# + my ($self, $name, $column, $value) = @_; + + my $regex = ''; + if ($column->{not_null} and not defined $value) { + $self->warn(NOTNULL => $column->{form_display} || $name); + } + if ($column->{type} eq 'ENUM' and $value) { + $regex = '^(?:' . join('|', map quotemeta, @{$column->{values}}) . ')$'; + } + elsif (defined $value) { + unless ($regex = $column->{regex}) { + my $sign = $column->{unsigned} ? '\+' : '[+-]'; + if ($column->{type} eq 'INTEGER' or $column->{type} =~ /INT$/) { + $regex = '^' . $sign . '?\d+$'; + } + elsif ($column->{type} =~ /^(?:REAL|FLOAT|DOUBLE|DECIMAL)$/) { + $regex = '^' . $sign . '?(?=\d|\.\d)\d*(\.\d*)?(?:[eE][+-]?\d+)?$'; + } + } + } + + if ($regex and not ref $value) { + if (eval { $value !~ /$regex/ }) { + $self->warn(ILLEGALVAL => $column->{form_display} || $name, $value); + } + elsif ($@) { + $self->warn(REGEXFAIL => $regex); + } + } + if (ref $self->{_error} and @{$self->{_error}}) { + $GT::SQL::error = join "\n", @{$self->{_error}}; + return; + } + return 1; +} + +sub _extract_where { +# ------------------------------------------------------------------- +# Takes the users input and extracts the +# hash refs or condition clause. Creates +# a Condition object and returns it. +# Returns where the query was a hash or not +# as well. +# + my @args = @_; + my $cond = GT::SQL::Condition->new; + my $do_select = 0; + for (@args) { + if (ref eq "HASH") { + while (my ($col, $val) = each %$_) { + $cond->add($col => '=' => $val); + } + } + elsif (ref eq 'GT::SQL::Condition') { + $do_select = 1; + $cond->add($_->clone); + } + } + return ($cond, $do_select); +} + +sub _build_cond { +# ------------------------------------------------------------------- +# this subroutine is done to build conditions +# which may not be a Condition +# for selects and deletes. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond->clone; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + for my $key (keys %{$cond}) { + next unless exists $cols->{$key}; + if (ref $cond->{$key} eq 'ARRAY') { + $tmp->add($key => IN => $cond->{$key}); + } + elsif (defined $cond->{$key}) { + $tmp->add($key => '=' => $cond->{$key}); + } + else { + $tmp->add($key => 'IS' => \'NULL'); + } + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition(@$cond); + return $tmp->clone; + } + $self->fatal(BADARGS => "_build_cond takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +sub _build_set { +# ------------------------------------------------------------------- +# Internal use. Builds the set options for the query. +# + my $self = shift; + my $cond = shift; + + my $cols = $self->{schema}->{cols}; + + if (ref $cond eq 'GT::SQL::Condition') { + return $cond; + } + elsif (ref $cond eq 'HASH') { + my $tmp = new GT::SQL::Condition; + $tmp->bool(','); + for my $key (keys %{$cond}) { + $tmp->add($key, "=", $cond->{$key}) if exists $cols->{$key}; + } + return $tmp; + } + elsif (ref $cond eq 'ARRAY') { + my $tmp = new GT::SQL::Condition (@{$cond}, ','); + return $tmp; + } + $self->fatal(BADARGS => "_build_set takes only a condition, array ref, or hash ref. Not: '$cond'"); +} + +$COMPILE{_check_keys} = __LINE__ . <<'END_OF_SUB'; +sub _check_keys { +# ------------------------------------------------------------------- +# Checks to see if the arguments passed into +# delete contains the externally linked columns +# + my ($self, $where) = @_; + ref $where or return $self->fatal(BADARGS => '_check_keys'); + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for ($self->fk_tables) { + my $new_schema = $self->new_table($_) or return $self->fatal(FKNOTABLE => $_, $GT::SQL::error); + my %hash = $new_schema->fk; + my $name = $self->name; + + for (values %{$hash{$name}}) { + return unless exists $cond->{$_}; + } + } + return 1; +} +END_OF_SUB + +$COMPILE{_do_opt} = __LINE__ . <<'END_OF_SUB'; +sub _do_opt { +# ------------------------------------------------------------------- +# Does a select or delete based on the option +# + my ($self, $opt, $sel_hashr, $table_name) = @_; + my $new_me = $self->new_table($table_name) or return $self->fatal(FKNOTABLE => $table_name, $GT::SQL::error); + if ($opt eq 'cascade') { + my $cond; + if ($self->{schema}->{tree} and keys %$sel_hashr > 1 and $self->tree->{tree}->name() eq $new_me->name()) { + $cond = []; + for (keys %$sel_hashr) { + push @$cond, GT::SQL::Condition->new($_ => '=' => $sel_hashr->{$_}); + } + } + else { + $cond = $sel_hashr; + } + if (ref $cond eq 'ARRAY') { + for (@$cond) { + $new_me->delete($_) or return; + } + } + else { + $new_me->delete($cond) or return; + } + } + else { + return $self->warn(DEPENDENCY => $table_name) if $new_me->count($sel_hashr); + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cond} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cond { +# ------------------------------------------------------------------- +# Performs the delete based on a condition object +# + my ($self, $where, $opt) = @_; + my $cond = ref $where eq 'HASH' ? $where : $where->as_hash; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + while (my ($k, $v) = each %$fk_href) { + $sel_hashr->{$k} = $cond->{$v} if exists $cond->{$v}; + } + + return $self->fatal(FKMISSING => $fktable, $self->name, $fktable) unless keys %$sel_hashr; + $self->_do_opt($opt, $sel_hashr, $fktable) or return; + } + return 1; +} +END_OF_SUB + +$COMPILE{_delete_select} = __LINE__ . <<'END_OF_SUB'; +sub _delete_select { +# ------------------------------------------------------------------- +# Performs the delete based on the cascade +# option +# + my ($self, $sth, $opt) = @_; + my $fk_del; + my $data = $sth->fetchall_hashref; + for my $fktable (@{$self->fk_tables}) { + my $new_schema = $self->new_table($fktable) or return $self->fatal(FKNOTABLE => $fktable, $GT::SQL::error); + my %fk = $new_schema->fk; + my $fk_href = $fk{$self->name}; + my $sel_hashr = {}; + for my $row (@$data) { + for my $fk (keys %$fk_href) { + push @{$sel_hashr->{$fk}}, $row->{$fk_href->{$fk}}; + } + } + $self->_do_opt($opt, $sel_hashr, $fktable) or return if keys %$sel_hashr; + } + + return 1; +} +END_OF_SUB + +$COMPILE{_delete_cleanup} = __LINE__ . <<'END_OF_SUB'; +sub _delete_cleanup { +# ------------------------------------------------------------------- +# Performs the delete based on one to many relationship. +# + my ($self, $where) = @_; + +# Get the SQL. + my $sth = $self->select($where); + + my $rows = $sth->fetchall_arrayref(); + return 0 unless $rows and @$rows; + + $sth = $self->{driver}->delete($where) or return; + + my $name = $self->name; + for my $fk_table ($self->fk_tables) { + + my $new_schema = $self->new_table($fk_table) or return $self->fatal(FKNOTABLE => $fk_table, $GT::SQL::error); + my %fk = $new_schema->fk; + my @ls = sort keys %{$fk{$name}}; + my $rel = $self->new_relation($fk_table, $self->name); + my %cond; + for my $col (@ls) { + my $c = $fk{$name}->{$col}; + $cond{"$name.$c"} = undef; + my @sel_limit = map $_->[$self->{schema}->{cols}->{$c}->{pos} - 1], @$rows; + next unless @sel_limit; + $cond{"$fk_table.$col"} = \@sel_limit; + } + my $sth = $rel->select('left_join', @ls, \%cond) or return; + my $cols = $new_schema->cols; + + my $pk_vals = $sth->fetchall_arrayref; + if (@ls > 1) { + for my $row (@$pk_vals) { + $new_schema->delete({ map { ($ls[$_] => $row->[$_]) } 0 .. $#ls }) or return; + } + } + elsif (@ls == 1) { + my @del = map $_->[0], @$pk_vals; + $new_schema->delete({ $ls[0] => \@del }) if @del; + } + } + return 1; +} +END_OF_SUB + +# Returns a hash of all columns that have positive weights. +$COMPILE{_weight_cols} = __LINE__ . <<'END_OF_SUB'; +sub _weight_cols { + my $self = shift; + return map { + $self->{schema}->{cols}->{$_}->{weight} + ? ($_ => $self->{schema}->{cols}->{$_}->{weight}) + : () + } keys %{$self->{schema}->{cols}}; +} +END_OF_SUB + +# a hash of all columns that have form_type file +$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB'; +sub _file_cols { + my $self = shift; + $self->{_file_cols} = { + map { + ($self->{schema}->{cols}->{$_}->{form_type} and uc $self->{schema}->{cols}->{$_}->{form_type} eq 'FILE') + ? ($_ => $self->{schema}->{cols}->{$_}) + : () + } keys %{$self->{schema}->{cols}} + } if !$self->{_file_cols} or shift; + + %{$self->{_file_cols}}; +} +END_OF_SUB + +# Returns true if first argument is a primary key. +$COMPILE{_is_pk} = __LINE__ . <<'END_OF_SUB'; +sub _is_pk { + for (@{$_[0]->{schema}->{pk}}) { + return 1 if $_ eq $_[1]; + } + return 0; +} +END_OF_SUB + +$COMPILE{_is_fk} = __LINE__ . <<'END_OF_SUB'; +sub _is_fk { +# ------------------------------------------------------------------- +# Returns true if first argument is a foreign key. +# + for (keys %{$_[0]->{schema}->{fk}}) { + return 1 if exists $_[0]->{schema}->{fk}->{$_}->{$_[1]}; + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is not null. +$COMPILE{_is_not_null} = __LINE__ . <<'END_OF_SUB'; +sub _is_not_null { + return( + exists $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + and $_[0]->{schema}->{cols}->{$_[1]}->{not_null} + ); +} +END_OF_SUB + +# Returns true if first argument is indexed. +$COMPILE{_is_indexed} = __LINE__ . <<'END_OF_SUB'; +sub _is_indexed { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{index}}) { + for my $index_col (@{$self->{schema}->{index}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +# Returns true if first argument is uniquely indexed. +$COMPILE{_is_unique} = __LINE__ . <<'END_OF_SUB'; +sub _is_unique { + my ($self, $col) = @_; + for my $index_name (keys %{$self->{schema}->{unique}}) { + for my $index_col (@{$self->{schema}->{unique}->{$index_name}}) { + return 1 if $index_col eq $col; + } + } + return 0; +} +END_OF_SUB + +$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB'; +sub _get_indexer { +#------------------------------------------------------------------------------- + my $self = shift; + $self->debug("CREATING GT::SQL::Indexer OBJECT") if ($self->{_debug} > 2); + require GT::SQL::Search; + my $indexer = GT::SQL::Search->load_indexer( + table => $self + ); + $indexer->debug_level($self->{_debug}); + return $indexer; +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::SQL::Table - a perl interface to manipulate a single SQL table. + +=head1 SYNOPSIS + + my $sth = $table->select(Column3 => { Column => $value, Column2 => $value2 }); + $table->delete({ Column => $value }); + $table->insert({ Column1 => $val, Column2 => $value2 }); + $table->update({ SetCol => $val }, { WhereCol => $val2 }); + +=head1 DESCRIPTION + +GT::SQL::Table provides methods to add, modify, delete and search over a single +SQL table. + +The following methods are provided. + +=head2 query, query_sth + +C provides a simple and powerful method to search a table. It takes as +input either a hash, hash ref or CGI object making it especially useful +searching from web forms. + + my $results = $db->query($in); + +The return of C is an arrayref of arrayrefs. C returns an STH +that you can fetch rows from. + +Typical usage to go through the results is: + + my $results = $db->query({ Title => 'foobar' }); + if ($results) { + for my $result (@$results) { + ... + } + } + +To specify what to search, you simply pass in column => search value. However, +you can also pass in a lot of options to enhance your search: + +Find all rows with field_name = value: + + field_name => value + +Find all rows with field_name > value: + + field_name => ">value" + +Find all rows with field_name < value: + + field_name => " value: + + field_name-gt => value + +Find all rows with field_name < value: + + field_name-lt => value + +Find all rows where any field_name = value: + + keyword => value + +Find all rows using indexed search (see weights): + + query => value + +Set to 1, use '=' comparison, 0/unspecified use 'LIKE '%val%' comparision: + + ww => 1 + +Search using LIKE for column 'Title' (valid opts are '=', '>', '<' or 'LIKE'): + + Title-opt => 'LIKE' + +Set to 1, OR match results, 0/unspecified AND match results: + + ma => 1 + +Return a max of n results, defaults to 25: + + mh => n + +Return page n of results: + + nh => n + +Sort by 'Title' column: + + sb => 'Title' + +Sort in ascending (ASC) or descending (DESC) order: + + so => 'ASC' + +=head2 select + +Select provides a way to implement almost any sql SELECT statement. + +An executed statement handle is returned that you can call the normal fetchrow, +fetchrow_array, fetchrow_hashref, etc on. + + my $sth = $obj->select; + +is equivalant to "SELECT * FROM Table" + + my $sth = $obj->select({ Col => Val }); + +is equivalant to "SELECT * FROM Table WHERE Col = 'Val'". + + my $sth = $obj->select('Col2', 'Col3', { Col => "Val" }); + +is equivalant to "SELECT Col2,Col3 FROM Table WHERE Col => 'Val'". + +So you can pass in a hash reference which represents the where clause, and an +array reference where represents what you want to select on. + +If you need more complex where clauses, you should use a condition object +instead of a hash reference. See L for more information. + +Notes: + +=over 4 + +=item quoting in where + +All arguments in the where clause are automatically quoted. If you don't want +quotes, you should pass in a scalar reference as in: + + my $sth = $obj->select({ Col => \"NOW()" }); + +which turns into "SELECT * FROM Table WHERE Col = NOW()". + +=item quoting in select + +Nothing in the select will be quoted, so to use functions, simply pass in what +you want: + + my $sth = $obj->select('COUNT(*)'); + +which turns into "SELECT COUNT(*) FROM Table". + +=back + +To specify LIMIT, or GROUP BY, or ORDER BY or other SELECT clauses that come +after the WHERE, you should use select_options below. + +=head2 select_options + +This method provides a way for you to specify select options such as LIMIT and +SORT_BY. + + $obj->select_options(@OPTIONS); + +@OPTIONS should be a list of options you want appended to your next select. + +For example, + + $obj->select_options('ORDER BY Foo', 'LIMIT 50'); + $obj->select; + +would turn into "SELECT * FROM Table ORDER BY Foo LIMIT 50". To perform a +LIMIT with an OFFSET, you should specify something like: + + $obj->select_options('LIMIT 25 OFFSET 75'); + +You can alternatively use the equivelant MySQL-specific syntax: + + $obj->select_options('LIMIT 75, 25'); + +Both will be handled correctly regardless of the database type. + +=head2 count + +This method will allow you to count records based on a where clause. + + my $count = $obj->count($condition); + +count() takes either a condition or a hash reference. If no argument is +provided, it is equivalant to "SELECT COUNT(*) FROM Table", or total number of +rows. + +=head2 hits + +This method returns the number of hits from that last select query B +the limit clause if there was one. + + $hits = $obj->hits; + +For example, to get rows 20-30 of a query result, use: + + $obj->select_options("LIMIT 10 OFFSET 20"); $obj->select({ Column => 'Foo' }); + +this translates into (in MySQL): + + SELECT * FROM Table WHERE Column = 'Foo' LIMIT 20, 10 + +To see the total number of results that the query would have retrieved without +any limit, you call: + + $hits = $obj->hits; + +If the number of hits can be calculated, it will be returned to you without any +additional query. Otherwise, the following query will be performed +automatically, and the hit count returned to you: + + SELECT COUNT(*) FROM Table WHERE Column = 'Foo' + +B: The hits() method _only_ applies to select queries. Most databases do +not provide enough information to get counts of rows affected for other types +of queries. + +=head2 get + +This method allows for a simple interface to retrieving records from the +table(s). + + my $rec_hash_ref = $obj->get($val); + my $rec_hash_ref = $obj->get($val, 'HASH', ['col1', 'col2']); + my $rec_array_ref = $obj->get($val, 'ARRAY'); + +The first argument is the primary key value of the record you want to retrieve. + +The second argument is a format option. It can be either 'ARRAY' or 'HASH' and +determines whether you are returned a HASH reference or an ARRAY reference. The +default is 'HASH', and it is optional. + +The last argument is a list of column names you want retrieved. C defaults +to returning the entire record, but if you only need specific columns, you can +ask for the ones you want. + +For example: + + my $employee = $emp_db->get('Alex'); + +would return a hash ref of the record whose primary key is equal to 'Alex'. + + my $emp_addr = $emp_db->get('Alex', 'HASH', ['City', 'State', 'ZipCode']); + +would return a hash ref of only the three fields City, State, ZipCode for the +record whose primary key equals Alex. + +=head2 add + +Method to add an entry into the database. This method can take it's arguments +one of three ways. + + $obj->add($CGI_OBJECT); + + -or- + + $obj->add({ + col1 => $val1, + col2 => $val2, + ... + }); + + -or- + + $obj->add( + col1 => $val1, + col2 => $val2, + ... + ); + +This method can take a cgi object, a hash reference or a hash. The keys of the +hash should be the names of the column and the values should be the values to +insert into the fields. The CGI Object is not different. If the table has an +auto_increment field, the value of the last inserted record will be returned. + +C returns undef on failure. If successful, and the table has an +auto-increment field, the auto increment value is returned. If there is no +auto increment value, then 1 is returned. Any errors will be in +$GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 will have the table module skip any error +checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 insert + +C is a lower level add. The main differences between C and +C are that add performs a not null check, and add returns the id of the +just inserted value. + +C does not perform a not null check. Also, insert returns the statement +handle used to do the insert (so you can call $sth->insert_id to get the auto +increment). + +=head2 insert_multiple + +C will try to optimize the insertion of multiple rows with +simple values. Under MySQL, this uses MySQL's extended insert syntax: + + INSERT INTO Table (col1, col2, col3) + VALUES ('val1', 'val2', 'val3'), ('val4', 'val5', 'val6'), ... + +On other databases, it attempts to perform all insertions in a single +transaction, which will also usually yield performance benefits. Note, +however, that C should not be used for anything more complex +than basic column values - for example, inserting NULL to set the current date, +or using raw SQL by passing scalar references for values. + +It takes at least two arguments - the first argument is an array ref of column +names, and the rest are array references of values. For example, to produce +the above example SQL code, you would call: + + $table->insert_multiple( + ['col1', 'col2', 'col3'], + ['val1', 'val2', 'val3'], + ['val4', 'val5', 'val6'], + ... + ); + +=head2 modify + +This method is designed for modifying a single entry in the table. It takes as +input a hash, hash ref or CGI object, which is assumed to represent a single +row with all fields intact. + +C will then look for the primary key in the input and set all fields +for that row equal to what was passed in. + +You need to pass in a complete record! If you just want to update one column, +you probably want to use C instead, as doing: + + my $result = $obj->modify(column1 => 'Foo'); + +will blank out all the other fields and set just column1 to Foo. + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 update + +This method provides a more robust way to update multiple entries in the table. + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + $condition + ); + + -or- + + my $result = $obj->update( + { + col1 => $val1, + col2 => $val2, + ... + }, + { + col1 => $val1, + col2 => $val2, + ... + } + ); + +In both these cases the first argument is a hash reference with the column +names as the keys and the new values you want the columns to hold as the +values. The second argument can either be a condition object or a hash +reference. If it is a hash reference the keys will be used as the column names +and the values will be taken as the current column values for the where clause +to update the table. + + $obj->update({ Setme => 'NewValue'}, { WhereCol => 5 }); + +would set the column 'Setme' to 'NewValue' where the column 'WhereCol' is 5. +This translates to: + + UPDATE Table SET SetMe='NewValue' WHERE WhereCol = 5 + +If the second argument is a GT::SQL::Condition object the condition object will +be used to build the where clause with. Please see L for a +description of what you can do with a where clause. + + my $condition = GT::SQL::Condition->new('WhereCol', 'LIKE', 'Foo%'); + $obj->update({ Setme => 'Newvalue' }, $condition); + +would translate to: + + UPDATE Table SET Setme = 'Newvalue' WHERE WhereCol LIKE 'Foo%' + +The condition can now much more complex where clauses though. + +C returns undef on failure and the a L statement +handle on success. The error message will be available in $GT::SQL::error. + +Passing in GT_SQL_SKIP_CHECK => 1 as a third option to C will have the +table module skip any error checking it should perform. + +Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the C method to do this. + +=head2 delete + +This method provides a robust interface to delete entries from your table(s) +using join and or foreign key relations. + + my $result = $obj->delete($condition); + +You can pass into C either a condition object to delete multiple +entries, or a scalar value to delete the row whose primary key equals the +value. If you have a multiple primary key, then you can pass in an array ref to +delete that row. + + my $result = $obj->delete({ + col1 => $val1, + col2 => $val2, + ... + ); + + -or- + + $obj->delete($val); + + -or- + + $obj->delete([$val1, $val2]); + +C returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error. + +=head2 delete_all + +This method takes no arguments and will erase all entries from a table. + +=head2 Table Properties + +Table provides a lot of methods to access information about the table: + +=over 4 + +=item name + +Provides the name of the table minus any prefix. + +=item ai + +Returns the name of the auto-increment field if any. + +=item pk + +Returns an array(ref) of primary key column names. + +=item fk + +Returns a hash of foreign key values. + +=item fk_tables + +Returns a list of tables with foreign keys pointing to this table. + +=item index + +Returns a hash ref of index name => array ref of column names that index uses. + +=item unique + +Returns a hash ref of unique index names => array ref of column names that +unique index uses. + +=item B + +Returns the joined output of index and unique and primary key. + +=item cols + +Returns a hash(ref) of column name => column definition + +=item default + +Returns a hash(ref) of column name => default value. + +=item size + +Returns a hash(ref) of column name => size of column in SQL. + +=item type + +Returns a hash(ref) of column name => type of column in SQL. + +=item form_display + +Returns a hash(ref) of column name => name to display on auto generated forms +(think pretty name). + +=item form_size + +Returns a hash(ref) of column name => size of html form to generate. + +=item form_type + +Returns a hash(ref) of column name => type of html form to generate (checkbox, +select, text, etc). + +=item form_names + +Returns a hash(ref) of column name => array ref of form names. This is used for +multi option form elements like checkboxes and multi selects. The name is what +is displayed to the user and not entered in the database. + +=item form_values + +Returns a hash(ref) of column name => array ref of form values. Same as above, +but this is the value that actually gets entered. + +=item time_check + +Returns a hash(ref) of column name => time check on or off. If set + +=item regex + +Returns a hash(ref) of column name => regular expression that all input must +pass before being inserted. + +=item pos + +Returns a hash(ref) of column name => position in table. + +=item not_null + +Returns a hash(ref) of column name => not null (whether the field is allowed to +be null or not). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Table.pm,v 1.274 2008/09/17 19:35:24 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree.pm new file mode 100644 index 0000000..6f9fe46 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree.pm @@ -0,0 +1,1269 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Tree.pm,v 1.30 2008/06/11 06:55:26 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Class used to manage a tree structure in a table. +# +# +# The comments through this document reference "record hash refs" - +# a record hash ref consists of 5 keys: +# - tree_id_fk => the ID +# - tree_anc_id_fk => the ancestor ID +# - tree_dist => The 'distance' between the id and the ancestor. If the +# ancestor is the father, this is 1; for the grandfather, 2 +# +# Most things have a common return, which looks like this: +# { id => [{ record }, { record2 }, { record3 }], id2 => [], ... } +# Where id, id2, ... are the ID's you pass in, and record, record2, record3, ... +# are the record hash refs mentioned above with the relationship requested (parents, +# children, siblings, etc.) +# +package GT::SQL::Tree; +# =============================================================== +use strict; +use GT::SQL::Condition; +use GT::SQL::Base; +use GT::SQL::Table; +use GT::AutoLoader; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants + TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ table => $table_obj })'); + + $self->{connect} = $self->{table}->{connect}; + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + my $tree_table = $self->{table}->name . "_tree"; # ->name returns the table _prefixed_ + my $name = $self->{connect}->{def_path} . '/' . $tree_table . '.def'; + -e $name or return $self->error(FILENOEXISTS => FATAL => $name); + + $tree_table = $self->new_table($tree_table); + + $self->{tree} = $tree_table; + + return $self; +} + +sub DESTROY {} + +$COMPILE{create} = __LINE__ . <<'END_OF_SUB'; +sub create { +# ----------------------------------------------------------- +# GT::SQL::Tree->create(...) +# Create a new table, $tablename . "_tree". +# The arguments are as follows: +# table => $table_obj, # This is the table object the tree is to be built upon. +# father => 'father_id_fk', # The column in the table that contains the father ID. It must already exist. +# root => 'root_id_fk', # The column in the table that contains the root ID. It must already exist. +# depth => 'rec_depth', # The column in the table that keeps track of the depth (below the root) of the record. +# +# Optional arguments: +# force => 'force', # Specifies to argument to GT::SQL::Creator->create. Typically, 'force' or 'check'. +# debug => $debug_level, # Specifies to debug level for the GT::SQL::Tree object. +# rebuild => $rebuild, # A GT::SQL::Tree::Rebuild object +# You'll get back a GT::SQL::Tree object, just as if you had called new() for +# a tree that already existed. +# +# The new table created will have the following keys: +# tree_id_fk : A foreign key to the primary key of the table passed in +# tree_anc_id_fk : Also a foreign key to the primary key, this one stores an ancestor of id_fk +# tree_dist : This stores the distance (levels) between the ID and the ancestor. +# +# To give an example of how this will all look, let's say we have a structure like this: +# a +# - b +# - c +# - d +# - e +# Where b and c are children of a, d is a child of c, and e is a child of d. +# There will be the normal records, one per element. So, the main table looks +# like this: +# +# +-------+------+--------------+------------+-----------+ +# | pk_id | name | father_id_fk | root_id_fk | rec_depth | +# +-------+------+--------------+------------+-----------+ +# | 1 | a | 0 | 0 | 0 | +# | 2 | b | 1 | 1 | 1 | +# | 3 | c | 1 | 1 | 1 | +# | 4 | d | 3 | 1 | 2 | +# | 5 | e | 4 | 1 | 3 | +# +-------+------+--------------+------------+-----------+ +# +# For this example, the associated tree table will look like this: +# +# +------------+----------------+-----------+ +# | tree_id_fk | tree_anc_id_fk | tree_dist | +# +------------+----------------+-----------+ +# | 2 | 1 | 1 | +# | 3 | 1 | 1 | +# | 4 | 3 | 1 | +# | 4 | 1 | 2 | +# | 5 | 4 | 1 | +# | 5 | 3 | 2 | +# | 5 | 1 | 3 | +# +------------+----------------+-----------+ +# +# This format allows GT::SQL::Tree to easily (one simply query) select all +# descendants or ancestors given an ID. +# +# Calling ->create() on a table with data may take quite some time as it will +# create a tree for that table. You can, however, use this to recreate the +# tree for a particular table. +# + my $class = shift; + my $input = $class->common_param(@_) or return $class->error(BADARGS => FATAL => 'GT::SQL::Tree->create(HASH or HASH REF)'); + + my $self = {}; + + bless $self, ref $class || $class; + $self->{_debug} = $input->{debug} if $input->{debug}; + + my $table = $input->{table}; + $table and $table->name or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., table => $table_obj, ...)'); + $input->{father} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., father => \'father_col\', ...)'); + $input->{root} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., root => \'root_col\', ...)'); + $input->{depth} or return $self->error(BADARGS => FATAL => 'GT::SQL::Tree->create(..., depth => \'depth_col\', ...)'); + + $self->{connect} = $table->{connect}; + + $table->pk and @{$table->pk} == 1 or return $self->error(TREEBADPK => FATAL => $table->name); + + # If a rebuild object was passed in, let it do its stuff. + if ($input->{rebuild}) { + $input->{rebuild}->_rebuild($table->pk->[0], @$input{qw/root father depth/}); + } + + my $tree = $table->name . "_tree"; + + my $c = $self->creator($tree); + + $c->cols([ + tree_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'ID' }, + tree_anc_id_fk => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Ancestor' }, + tree_dist => { type => 'INT', unsigned => 1, not_null => 1, form_display => 'Distance' } + ]); + + my $table_name = $table->name(); + $table_name =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $pk = $table->pk()->[0]; + $c->fk({ + $table_name => { tree_id_fk => $pk, tree_anc_id_fk => $pk } + }); + + $c->subclass({ + relation => { "${table_name}\0${table_name}_tree" => 'GT::SQL::Tree::Relation' } + }); + + my $tree_i_prefix = lc substr($table_name, 0, 4); + + $c->index({ + "${tree_i_prefix}_tri" => ['tree_id_fk'], + "${tree_i_prefix}_tra" => ['tree_anc_id_fk', 'tree_dist'] + }); + + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_ROOT] = $input->{root}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_FATHER] = $input->{father}; + $c->{table}->{schema}->{tree_cols}->[TREE_COLS_DEPTH] = $input->{depth}; + + $self->debug("Creating tree table '$tree'") if $self->{_debug}; + my $ok = $c->create($input->{force} || 'force'); + + if (!$ok) { + if ($GT::SQL::errcode eq 'TBLEXISTS') { + $c->set_defaults(); + $c->save_schema(); + } + else { + return; + } + } + + $table->fk($table_name => { $input->{father} => $pk }); + + $table->{schema}->{tree} = 1; + $self->debug("Saving tree existance in parent schema") if $self->{_debug}; + $table->save_state(); + $self->{table} = $table; + $self->{tree} = $self->new_table($tree); + + return $self unless $ok and $table->count(); # $ok will be false if we were instructed NOT to overwrite the table + + # Uh oh, this is fun... it means we have to create the tree from the existing table. + $self->debug("$table_name already has rows; building new tree table data") if $self->{_debug}; + $self->{tree}->delete_all(); + + my ($root_col, $depth_col, $father_col) = ($self->root_id_col, $self->depth_col, $self->father_id_col); + + my $top = $table->select("MAX($pk)")->fetchrow; + my $count = $table->count(); + my $roots = $table->count($root_col => 0); + $self->debug("Building ancestor tree ...") if $self->{_debug}; + my ($j, %parents, %depth); # %parent = ( id => [parents], id => [parents], ... ), %depth = ( $id => $depth, $id => $depth, ... ) + + for (my $i = 0; $i < $top; $i += 500) { # Get 500 threads at a time + $table->select_options("ORDER BY $root_col, $depth_col"); + my $cond = GT::SQL::Condition->new($root_col => '>' => $i, $root_col => '<=' => $i + 500); + + my $sth = $table->select($pk, $root_col, $father_col, $depth_col => $cond); + + my $last_root = 0; + %parents = (); + while (my ($id, $root, $parent, $depth) = $sth->fetchrow) { + if ($parent == $root) { + $parents{$id} = [$parent]; + } + else { + $parents{$id} = [@{$parents{$parent} || []}, $parent]; + } + $depth{$id} = $depth; + $self->debug("Processed $j records...") if $self->{_debug} and (++$j % 5000) == 0; + } + my @inserts; + if (keys %parents) { + for my $id (keys %parents) { + for my $anc (@{$parents{$id}}) { + push @inserts, [$id, $anc, $depth{$id} - ($depth{$anc} || 0)]; + } + } + } + + $self->{tree}->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @inserts) if @inserts; + } + + $self->debug("$j non-root nodes found.") if $self->{_debug}; + + return $self; +} +END_OF_SUB + +$COMPILE{destroy} = __LINE__ . <<'END_OF_SUB'; +sub destroy { +# ----------------------------------------------------------- +# $obj->destroy +# Drops the tree for the table of the current object. + + my $self = shift; + my $c = $self->creator($self->{table}->name . "_tree"); + + $c->drop_table; + + delete $self->{table}->{schema}->{tree}; + $self->{table}->save_state(); + + return 1; +} +END_OF_SUB + +sub root_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_ROOT]; +} + +sub father_id_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_FATHER]; +} + +sub depth_col { +# ----------------------------------------------------------- +# $tree->father_id_col +# Returns the father_id column. Takes no arguments. + shift->{tree}->{schema}->{tree_cols}->[TREE_COLS_DEPTH]; +} + +$COMPILE{insert} = __LINE__ . <<'END_OF_SUB'; +sub insert { +# ----------------------------------------------------------- +# $tree->insert(insert_id => $inserted_id, data => $insert_hash); +# This will insert the approriate record into the tree table. +# $inserted_id should be the insert_id of the new record and +# $insert_hash should contain at least the father, root, and +# depth columns. +# The number of rows inserted into the tree table is returned +# on success. Note that 0 is returned as 0e0 for a root. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->insert(HASH or HASH_REF)'); + + my $table = $self->{tree} or return $self->error(NOTREEOBJ => FATAL => '$tree->insert()'); + + my $insert_id = $input->{insert_id}; + my $data = $input->{data}; + + my $f = $self->father_id_col; + + return "0e0" unless my $fid = $data->{$f}; # If there is no father, it's a root, so we don't do anything. + + my $parents = $self->parents(id => $fid); + + push @$parents, { tree_id_fk => $fid, tree_anc_id_fk => $fid, tree_dist => 0 }; # tree_id_fk isn't used, and dist will have one added to it to get the node-father row + + my @insertions; + for (@$parents) { + my ($anc, $depth) = @$_{'tree_anc_id_fk', 'tree_dist'}; + + push @insertions, [$insert_id, $anc, $depth + 1]; + } + $table->insert_multiple(['tree_id_fk', 'tree_anc_id_fk', 'tree_dist'], @insertions); + + return scalar @insertions; +} +END_OF_SUB + +$COMPILE{pre_update} = __LINE__ . <<'END_OF_SUB'; +sub pre_update { +# ----------------------------------------------------------------------------- +# $tree->update(where => $condition, data => $update_hash); +# $update_hash should contain the father_id column. This should only be +# called (by GT::SQL::Table) when an update occurs that changes the +# father_id. $update_hash must be the hash reference that will be used for +# the update because it is going to be changed for the root and depth fields. +# You're going to get back some sort of data structure from this (subject to +# change). Pass the data structure into "update" after the update occurs +# successfully. + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->update(HASH or HASH REF)'); + + my $update_hash = $input->{data} or return $self->error(BADARGS => FATAL => '$tree->update(... data => $update_hash ...)'); + + my $where = $input->{where} or return $self->error(BADARGS => FATAL => '$tree->update(... where => $condition ...)'); + + my ($pk, $r, $f, $d) = ($self->{table}->pk()->[0], $self->root_id_col, $self->father_id_col, $self->depth_col); + + my $new_father = $input->{data}->{$f}; + my ($table, $tree) = ($self->{table}, $self->{tree}); + my %ids = $self->{table}->select($pk, $d => $where)->fetchall_list; + if ($new_father and exists $ids{$new_father}) { + # Cannot update a row to be a child of itself + return $self->error(TREEFATHER => 'WARN'); + } + # keys %ids are the ID's of the records being moved. The values are the depth BEFORE moving. + my $old_parents = $self->parent_ids(id => [keys %ids]); + my $children = $self->child_ids(id => [keys %ids], include_dist => 1); + + my $delete_cond; + for my $parent (keys %ids) { + my @p = @{$old_parents->{$parent}}; + my @c = keys %{$children->{$parent}}; + for (@c) { + if ($_ == $new_father) { + # We can't update a row to be a child of it's children + return $self->error(TREEFATHER => 'WARN'); + } + } + + next unless @p; # If there aren't any old parents, this record already is a root and isn't changing. + + $delete_cond ||= GT::SQL::Condition->new('OR'); + + $delete_cond->add( + GT::SQL::Condition->new( + tree_anc_id_fk => IN => \@p, + tree_id_fk => IN => [$parent, keys %{$children->{$parent}}] + ) + ); + } + + my ($new_depth, $new_root_id, $update, @insert) = (0, 0); + if ($new_father) { + my %new_parents = ($new_father => 0, %{$self->parent_ids(id => $new_father, include_dist => 1)}); + my %insert_seen; + for my $new (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + for my $new_child ($new, keys %{$children->{$new}}) { + next if $insert_seen{$new_child}++; # If it's already seen, it means it's already been handled. This can occur when moving both a child and parent to be children of a new node - the child will be a sibling of its old parent + for my $new_anc (keys %new_parents) { + my $child_dist = $new_child == $new ? 0 : $children->{$new}->{$new_child}; + push @insert, [$new_anc, $new_child, $new_parents{$new_anc} + 1 + $child_dist] unless $insert_seen{"$new_anc\0$new_child"}++; + } + } + } + + ($new_depth, $new_root_id) = $self->{table}->select($d, $r => { $pk => $new_father })->fetchrow; + $new_root_id ||= $new_father; + $new_depth++; + + my %seen; + push @$update, { set => { $r => $new_root_id }, where => { $pk => [grep !$seen{$_}++, keys %ids, map { keys %{$children->{$_}} } keys %$children] } }; + } + else { + $update_hash->{$r} = 0; + my %seen; + for (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + push @$update, { set => { $r => $_ }, where => { $pk => [grep !$seen{$_}++, keys %{$children->{$_}}] } }; + } + } + + my ($delta, %updates, %seen); + for my $parent (sort { $ids{$b} <=> $ids{$a} } keys %ids) { + $delta = $new_depth - $ids{$parent}; + next if !$delta or $seen{$parent}++; + push @{$updates{$delta}}, $parent; + for (keys %{$children->{$parent}}) { + unless ($seen{$_}++) { + $self->debug("Adjusting depth of $_ by $delta") if $self->{_debug}; + push @{$updates{$delta}}, $_; + } + } + } + + for my $delta (keys %updates) { + push @$update, { set => { $d => \"$d + $delta" }, where => { $pk => $updates{$delta} } }; + } + + return { delete => $delete_cond, insert_multiple => [[qw/tree_anc_id_fk tree_id_fk tree_dist/], @insert], update => $update }; +} +END_OF_SUB + +$COMPILE{update} = __LINE__ . <<'END_OF_SUB'; +sub update { +# --------------------------------------------------------- +# This basically executes whatever is decided above. pre_update +# is where everything important is decided. + my $self = shift; + my $input = shift; # This should be whatever pre_update returned. + if ($input->{delete}) { + $self->debug("Deleting now-invalid tree records") if $self->{_debug} >= 1; + $self->{tree}->delete($input->{delete}); + } + if ($input->{insert_multiple} and @{$input->{insert_multiple}} >= 2) { + $self->debug("Inserting new tree records required") if $self->{_debug} >= 1; + $self->{tree}->insert_multiple(@{$input->{insert_multiple}}); + } + if ($input->{update}) { + $self->debug("Updating tree depths required after an update") if $self->{_debug} >= 1; + for (@{$input->{update}}) { + $self->{table}->update($_->{set}, $_->{where}); + } + } +} +END_OF_SUB + +sub children { +# ----------------------------------------------------------- +# $tree->children(id => [$pkval1, $pkval2, ...], max_depth => $max_depth) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->children(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if defined $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->children()'); + for (@$ids) { + $ids = 0 if not $_; + } + + my $parent = $self->{table}->name(); + my $tree = $self->{tree}->name(); + my $roots_only = $input->{roots_only}; + $roots_only = 1 if not $ids; + my ($select_from, $left_join); + if ($roots_only and ref $input->{select_from}) { + $select_from = $input->{select_from}; + $left_join = $input->{left_join}; + } + elsif ($ids and !$roots_only) { + $select_from = $self->{table}->new_relation($parent, $tree); + } + else { + $select_from = $self->{table}; + } + + my $max_depth = $input->{max_depth}; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my $pk = $self->{table}->pk()->[0]; + my $cond; + + my $sort_col = $input->{sort_col} || []; + my $sort_order = $input->{sort_order} || []; + $sort_col = [$sort_col] if $sort_col and not ref $sort_col; + $sort_order = [$sort_order] if $sort_order and not ref $sort_order; + my $sort_col_saved = [@$sort_col]; + my $order_by; + if ($sort_col) { + if (@$sort_order) { + for (0 .. $#$sort_col) { + last if $_ > $#$sort_order; + $sort_col->[$_] .= " $sort_order->[$_]" if $sort_order->[$_]; + } + } + $order_by = "ORDER BY " . join ", ", @$sort_col if @$sort_col; + } + + if ($input->{condition} and UNIVERSAL::isa($input->{condition}, 'GT::SQL::Condition')) { + $cond = new GT::SQL::Condition; + $cond->add($input->{condition}); + } + my %roots_order; # We might need this, if using the roots_order_by option. + if ($ids) { + $cond ||= new GT::SQL::Condition; + if ($roots_only) { + $cond->add("$parent.$root_col" => IN => $ids); + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + else { + $cond->add("$tree.tree_anc_id_fk" => IN => $ids); + $cond->add("$tree.tree_dist" => '<=' => $max_depth) if $max_depth; + } + } + else { + if ($roots_only and $input->{limit}) { + # The following only applies when a limit is being used - otherwise, everything will be returned. + my $c = new GT::SQL::Condition; + $c->add($cond) if $cond; + $c->add($root_col => '=' => 0); + + if ($input->{roots_order_by}) { + $self->{table}->select_options('ORDER BY ' . $input->{roots_order_by}); + } + else { + $self->{table}->select_options($order_by); + } + $self->{table}->select_options("LIMIT $input->{limit}"); + + my @roots = $self->{table}->select($pk => $c)->fetchall_list; + if ($input->{roots_order_by}) { + my $r; + %roots_order = map { ($_ => $r++) } @roots; + } + my @children = $self->{table}->select($pk => { $root_col => \@roots })->fetchall_list; + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$pk" => IN => [@roots, @children]); + } + $cond ||= new GT::SQL::Condition; + $cond->add("$parent.$depth_col" => '<=' => $max_depth) if $max_depth; + } + + my $get_cols = $input->{cols}; + $get_cols = [$get_cols] if $get_cols and not ref $get_cols; + if ($get_cols) { + my ($found_root, $found_father, $found_depth, $found_anc); + for (@$get_cols) { + last if $found_root and $found_father and $found_depth; + $found_anc++ if not $found_anc and $_ eq 'tree_anc_id_fk'; + $found_root++ if not $found_root and $_ eq $root_col; + $found_depth++ if not $found_depth and $_ eq $depth_col; + $found_father++ if not $found_father and $_ eq $father_col; + } + push @$get_cols, $root_col if not $found_root; + push @$get_cols, $depth_col if not $found_depth; + push @$get_cols, $father_col if not $found_father; + push @$get_cols, 'tree_anc_id_fk' unless $found_anc or $roots_only; + push @$get_cols, 'tree_dist' unless $roots_only; + } + + $select_from->select_options($order_by) if $order_by; + my $sth = $select_from->select($left_join ? ('left_join') : (), $get_cols || (), $cond || ()); + + my $return = $self->_sort($sth, !$ids, $roots_only, (keys %roots_order ? \%roots_order : ())); + + if ($ids) { + for (@$ids) { + $return->{$_} ||= []; + } + } + return $ref ? $return : $return->{$ids ? $ids->[0] : 0}; +} + +sub _sort { +# ----------------------------------------------------------- +# Used internally. Sorts an array ref of hash refs into the +# proper order for a tree. + my ($self, $sth, $from_root, $roots_only, $rp) = @_; + my $pk = $self->{table}->pk()->[0]; + my $root_col = $self->root_id_col; + my $depth_col = $self->depth_col; + my $father_col = $self->father_id_col; + my (@recs, %children, %root_pos, $r); +# When we're done this first part, @recs and %children will look like: +# +# @recs = ( +# [$thread1_immediate_child1, $thread1_immediate_child2, ...], +# [$thread2_immediate_child1, $thread2_immediate_child2, ...], +# ... +# ); +# %children = ( +# $ancestor_id => { +# $child_level_1_rec_1_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# $child_level_1_rec_2_id => [$child_level_2_rec_1, $child_level_2_rec_2, ...], +# ... +# }, +# $ancestor_id => { ... }, +# ... +# ) +# +# Each element in @recs contains the immediate children of a requested base row +# (often a root, but not necessarily). Root positions are stored in %root_pos, +# so that all appropriate rows of a tree are grouped together. +# +# The $ancestor_id in %children is the requested ID. If requesting just roots, +# this is the root ID, otherwise it is the ancestor ID. +# +# To determine the final list, each element will have its children placed +# immediately after itself in a recursive-like way, though not implemented here +# with recursion. +# +# Also note that duplicates are possible, when a requested "root" is really a +# child/descendant of another requested root. + +# $anc_col is how a thread relates; typically this is the root_id, but isn't +# required to be when not using roots_only. + my $anc_col = $roots_only ? $root_col : 'tree_anc_id_fk'; + + while (my $rec = $sth->fetchrow_hashref) { + if (not exists $root_pos{$rec->{$anc_col} || $rec->{$pk}}) { # We haven't encountered this root yet. + $root_pos{$rec->{$anc_col} || $rec->{$pk}} = $from_root ? 0 : $r++; + } + if ($roots_only) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec + if $rec->{$anc_col}; + + push @{$recs[$root_pos{$rec->{$anc_col} || $rec->{$pk}}]}, $rec + if $rec->{$depth_col} == ($from_root ? 0 : 1); + } + else { + if ($rec->{tree_dist} > 1) { + push @{$children{$rec->{$anc_col}}->{$rec->{$father_col}}}, $rec; + } + else { + push @{$recs[$root_pos{$rec->{$anc_col}}]}, $rec; + } + } + } + + my @sorted; +# The goal here is to make @sorted look like this: +# @sorted = ( +# [$reply1, $reply2, ...], +# [$reply1, $reply2, ...], +# ... +# ); +# Each array ref corresponds to one tree. Note that $reply1 could be a root, not a reply :) + +# The mess below properly sorts out a thread, paying attention to both the +# parent and, if specified, sort_col and sort_order. + + # Go through all threads in @recs - each element is a thread + for my $thread (@recs) { + while (@$thread) { + my $this = shift @$thread; + if (my $children = $children{$this->{$anc_col} || $this->{$pk}}->{$this->{$pk}}) { + unshift @$thread, @$children; + } + my $sort_i = $root_pos{$this->{$anc_col} || $this->{$pk}}; + push @{$sorted[$sort_i]}, $this; + } + } + + if ($from_root and $rp) { # If $rp was passed in, order the array refs according to $rp->{$root_id} +# $sort[0] is sorted for all the elements. What we have to do now is group them into threads. + my $i; + my %cur_pos = map { ("$_" => $i++) } @{$sorted[0]}; + $sorted[0] = [ + sort { + ( # This bit sorts by root ID + $rp->{$a->{$anc_col} || $a->{$pk}} + <=> + $rp->{$b->{$anc_col} || $b->{$pk}} + ) + || + ($cur_pos{$a} <=> $cur_pos{$b}) # Keep the order for elements with the same root id + } + @{$sorted[0]} + ]; + } + + my $return = {}; + for my $tree (@sorted) { + my $root = $from_root ? 0 : $tree->[0]->{$anc_col}; + push @{$return->{$root}}, @$tree; + } + + $return; +} + +$COMPILE{parents} = __LINE__ . <<'END_OF_SUB'; +sub parents { +# ----------------------------------------------------------- +# $tree->parents(id => [$pkval1, $pkval2, ...]) +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parents(HASH or HASH_REF)'); + + $self->{tree} and $self->{table} or return $self->error(NOTREEOBJ => FATAL => '$tree->parents()'); + + my $parent = $self->{table}->name(); + $parent =~ s/^\Q$self->{connect}->{PREFIX}\E//; + my $tree = $self->{tree}->name(); + $tree =~ s/^\Q$self->{connect}->{PREFIX}\E//; + + my $rel = $self->{table}->new_relation($parent, $tree); + + my $get = $input->{cols}; + $get = [] unless ref $get eq 'ARRAY'; + my $depth = $self->depth_col; + if (@$get) { # If $get is empty, everything will be returned. + my ($found_t, $found_d); + for (@$get) { + $found_t++ if $_ eq 'tree_id_fk'; + $found_d++ if $_ eq $depth; + last if $found_t and $found_d; + } + push @$get, 'tree_id_fk' if not $found_t; + push @$get, $depth if not $found_d; + } + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not $ref; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parents()'); + + $GT::SQL::Tree::Relation::Anc_Join = 1; + my $sth = $rel->select(@$get => { tree_id_fk => $ids }); + $GT::SQL::Tree::Relation::Anc_Join = 0; + + my $return = { map { ($_ => []) } @$ids }; + + while (my $rec = $sth->fetchrow_hashref) { + push @{$return->{$rec->{tree_id_fk}}}, $rec; + } + + for (@$ids) { + @{$return->{$_}} = sort { $a->{$depth} <=> $b->{$depth} } @{$return->{$_}}; + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{child_ids} = __LINE__ . <<'END_OF_SUB'; +sub child_ids { +# ----------------------------------------------------------- +# $tree->child_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing at least an 'id' key. +# The value of the 'id' key is an array reference of ancestor ID's whose +# descendants (children, children's children, etc.) you are looking for. +# max_depth can be specified to limit a maximum child depth to return. +# OUT: Depends on include_dist. +# Without include_dist: hash ref of array ref. There will be one key for +# each ID you pass in. If there are no children, the array ref value will +# contain no elements. Each array element is a child ID. +# With include_dist: hash ref of hash refs. One key for each ID you pass +# in. The inner hash refs have keys of the ID's and values of the +# distance between what you passed in and the element. Essentially, +# keys() of an include_dist hash is the same as the array ref without +# include depth. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->child_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->child_ids()'); + + my @get = qw/tree_anc_id_fk tree_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_anc_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($anc, $id, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$anc}->{$id} = $dist; + } + else { + push @{$return->{$anc}}, $id; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{parent_ids} = __LINE__ . <<'END_OF_SUB'; +sub parent_ids { +# ----------------------------------------------------------- +# $tree->parent_ids(id => [$pkval1, $pkval2, ...], include_dist => 1) +# IN : A hash or hash ref containing an 'id' key. +# The value of the 'id' key is an array reference of children ID's whose +# ancestors (parents, parents' parents, etc.) you are looking for. +# OUT: hash ref of array refs. There will be one key for each ID you pass in. +# Each array ref contains the ID's of the parents. +# Liks child_ids, the return is different if you pass in "include_dist". +# See child_ids for a description. +# + my $self = shift; + my $input = $self->common_param(@_) or return $self->error(BADARGS => FATAL => '$tree->parent_ids(HASH or HASH_REF)'); + + my $ids = $input->{id}; + my $ref = ref $ids; + $ids = [$ids] if $ids and not ref $ids; + $ids and @$ids or return $self->error(TREENOIDS => FATAL => '$tree->parent_ids()'); + + my @get = qw/tree_id_fk tree_anc_id_fk/; + push @get, 'tree_dist' if $input->{include_dist}; + my $sth = $self->{tree}->select(@get => { tree_id_fk => $ids }); + + my $return = { map { ($_ => $input->{include_dist} ? {} : []) } @$ids }; + + while (my ($id, $anc, $dist) = $sth->fetchrow) { + if ($input->{include_dist}) { + $return->{$id}->{$anc} = $dist; + } + else { + push @{$return->{$id}}, $anc; + } + } + + return $ref ? $return : $return->{$ids->[0]}; +} +END_OF_SUB + +$COMPILE{num_children} = __LINE__ . <<'END_OF_SUB'; +sub num_children { +# ----------------------------------------------------------------------------- +# $tree->num_children([$pkval1, $pkval2, ...]) +# IN : A list or array reference of of parents ID's whose child counts +# you are looking for. +# OUT: Hash reference of ID => NUM_CHILDREN pairs. Note that this is the +# number of children (i.e. depth = 1), not descendants. +# + my $self = shift; + + my @ids = map { + ref eq 'ARRAY' + ? @$_ + : ref() + ? $self->error(BADARGS => FATAL => '$tree->num_children(ARRAY or ARRAYREF)') + : $_ + } @_; + + @ids or return $self->error(TREENOIDS => FATAL => '$tree->num_children()'); + + $self->{tree}->select_options('GROUP BY tree_anc_id_fk'); + my %return = $self->{tree}->select(tree_anc_id_fk => 'COUNT(*)', { tree_anc_id_fk => \@ids, tree_dist => 1 })->fetchall_list; + + for (@ids) { $return{$_} ||= 0 } + + return \%return; +} +END_OF_SUB + + +package GT::SQL::Tree::Relation; +# This is here to subclass the table->tree relation so that selects work properly + +use GT::SQL::Relation; +use vars qw/@ISA $ERROR_MESSAGE $Anc_Join/; # $Anc_Join is set by the tree module when the join should be on tree_anc_id_fk rather than tree_id_fk +@ISA = $ERROR_MESSAGE = 'GT::SQL::Relation'; + +sub _join_query { +# ------------------------------------------------------------------- +# Figures out the join clause between tables. +# + my $self = shift; + my $relations = shift; + if (@$relations != 2) { + return $self->error(TREEBADJOIN => FATAL => "@$relations"); + } + my ($table, $tree) = @$relations; + ($table, $tree) = ($tree, $table) if !$relations->[0]->{schema}->{tree}; + + return "$tree->{name}." . ($Anc_Join ? 'tree_anc_id_fk' : 'tree_id_fk') . " = $table->{name}." . $table->pk()->[0]; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree - Helps create and manage a tree in an SQL database. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + + my $tree = $table->tree; + my $children = $tree->children(id => [1,2,3], max_depth => 2); + + my $parents = $tree->parents(id => [4,5,6]); + +=head1 DESCRIPTION + +GT::SQL::Tree is designed to implement a tree structure with a SQL table. Most +of the work on managing the table is performed automatically behind the scenes, +however there are a couple of front end methods to retrieving the tree nodes +from a GT::SQL::Tree object. + +=head1 METHODS + +=head2 new, tree + +Typically, the way to get a tree object is to call ->tree on a table object. The +table object then calls GT::SQL::Tree->new for you and returns the results, +which is a GT::SQL::Tree object. Typically you should not call ->new directly, +but instead let $table->tree call it with the proper arguments. + +=head2 create, add_tree + +To use GT::SQL::Tree, you need to first call create(). You shouldn't call it +directly, but instead call ->add_tree() on an editor object. The arguments to +add_tree are passed through to create, so that they are essentially the same +(there is one exception - add_tree passed in C $table_object>). + +create() will create a tree table, with the name passed on the name of the table +passed in. For example, if you wish to build a tree on 'MyTable', the tree table +that is created by create() will be named MyTable_tree. The tree table provides +easy one-query access to all of a nodes parents or children, and also keeps +track of the number of hops between a node and its descendant, allowing you to +limit how far you descend into the tree. + +The following arguments are required: + +=over 4 + +=item table + +This contains the table object for the table the tree is to be built upon. Note +that when calling add_tree you B specify this - add_tree passes it +along on its own. + +=item father + +This must specify the name of the father ID column. The father ID column +controls the relationship between father/child. + +For example, if your primary key is "my_id" and your father id column is +"my_father_id", you would pass in "my_father_id" as the value to C. + +=item root + +This is used to specify the name of the root column. For example, if your +primary key is "my_id" and your root id column is "my_root_id", you would pass +in "my_root_id" as the value to C. + +=item depth + +This is used to specify the name of the depth column for the table. For example, +if you are using a column named "my_depth" to keep track of the depth of a node, +you would pass in "my_depth" as the value to C. + +=back + +The following are optional arguments to create/add_tree: + +=over 4 + +=item force + +Takes a value such as 'force' or 'check'. This value is passed on to the +GT::SQL table creation subroutine. + +=item rebuild + +You can pass in a GT::SQL::Tree::Rebuild object if you have an incomplete or +invalid table structure. See L for more details. + +=item debug + +Sets the debug level of the tree object. add_tree() automatically passes in the +debug value for the table object, so it normally is not necessary to set this. + +=back + +=head2 destroy, drop_tree + +You can call C<$tree-Edestroy> to destroy a tree. This involves dropping the +tree table and deleting the tree reference from the table the tree was on. This +can be called by calling C<$tree-Edestroy()> on a GT::SQL::Tree object, +however this is typically invoked by calling C<$editor-Edrop_tree()> on a +table editor object. + +Neither C<$tree-Edestroy()> nor C<$editor-Edrop_tree()> take any +arguments. + +=head2 root_id_col, father_id_co, depth_col + +These three tree object methods return the name of the associated column in the +main table. Usually you will already know them, and these methods are primarily +used internally. + +=head2 children + +This is where the usefulness of the tree module comes into play. +C<$tree-Echildren> is used to access all of the children of a particular +node. It takes a wide variety of arguments to control the return. + +Usually, the return will be either a hash reference of array references each +containing hash references, or else an array reference of hash references. Which +reference you get depends on what you request via the C parameter, described +below. Each inner hash reference is a row from the database, typically a joined +row from the table the tree is on with the tree table, however the +C, C, and C parameters all change this behaviour. + +The arguments to C are as follows: + +=over 4 + +=item id + +The value of the id key is either a scalar value, or an array reference. The +value/values to id should be the id whose descendants you are looking for. For +example, if you are looking for the children of ID 3 and ID 4, you would pass in +C [3, 4]>. The return value of children will be a hash reference +containing two keys: 3 and 4. + +If you are looking for the children of a single ID and pass the id as a scalar +value, you will get back an array reference as described above. + +So, basically, if the value to id is an array reference, you will get back a +hash reference of array references of hash references; if it is a scalar value, +you will get back an array reference of hash references. + $tree->children(id => [1])->{1}; +and + $tree->children(id => 1); +will result in the same thing. + +To get all the trees in a single query, you pass in 0 as the value. This is as +if you are requesting the children of the imaginary root to which all roots +belong. + +C is the only required parameter. + +=item max_depth + +You can specify a max_depth value to specify that the records returned should +not be more a certain distance from the node. For example, supposing you have +this tree: + a + b + c + d +Selecting the children of a with a max_depth of 1 would return just b, not c or +d. A max_depth of 2 would return b and c. + +Not specifying max_depth means that you do not want to limit the maximum +distance from the parent of the returned values. + +=item cols + +You can specify an array reference as the value to C to alter the values +returned. Instead of doing "SELECT * FROM ...", the query will be "SELECT FROM ...". Note, however, that the father, root, and depth columns +are required and will be present in the rows returned whether or not you specify +them. + +=item sort_col, sort_order + +Where the C option sorts the results based on tree levels, C and +C control the sorting for nodes with the same father ID. For +example, with this tree: + a + b + c +C and C affect whether or not b comes before or after c. +The value of each can either be a scalar value or an array reference. There is +essentially no difference, the scalar value is just a little easier when you are +only sorting on a single column. The values of C should be column +names, and the values of C 'ASC' or 'DESC', per sort column +respectively. For example: + sort_col => ['a','b'], sort_order => ['ASC', 'DESC'] +will sort first in ascending order based on the value of a, then descending +order based on the value of column b. This correlates directly to SQL - it +becomes "ORDER BY a ASC, b DESC". + +You can specify a different sort order for roots by using the C +option, when using C 0>. See below. + +=item condition + +If you want to limit the results, you can pass a GT::SQL::Condition object into +C via the condition key. The condition will apply to the select +performed. For example, if you want to select rows with a column "a" having a +value less than 20, you could do: + my $cond = GT::SQL::Condition->new(a => '<' => 20) + my $children = $tree->children(..., condition => $cond); + +=item limit + +Like condition, you can specify any valid LIMIT _____ value here, for example +"50, 25". This option is only used when using C 0> - it will limit the +number of roots returned, taking into account the sort_col and sort_order. + +=item roots_only + +If you specify this option, it will assume that what you passed in via C +consists only of root_ids. Doing so makes a join with the tree table +unneccessary and allows you to use the C option. This option can be +used (and generally this is a good idea) when specifying C 0>. + +=item roots_order_by + +This option controlls the order of root posts, when selecting roots using +C 0> and a limit. C above will affect the order of +children of the roots, but the order of the roots themselves will be controlled +by whatever C value you specify here. + +Again, this option requires that C 0>, C, and C are +also being used. + +If this option is omitted, the C will be generated from the values of +the C and C options. + +=item select_from + +If you are using roots_only, you can also specify the C option. +This option allows you to perform the selects from a GT::SQL::Relation object +instead of just the table associated with the tree. Note that the table +associated with the tree must be part of the relation, however you can have as +many other tables as you like. + +=item left_join + +If the select_from relation should be a left join, pass C 1>. +This simply passes the C option to ->select. This option is only +applicable when select_from is used. + +=back + +=head2 parents + +This is effectively the opposite of children. Instead of getting back all of the +children nodes, it gives the parents, all the way up to the root for any given +node. The return value is the same as that of C, so see that section. + +Each array returned by C is sorted by depth from root to parent. + +=over 4 + +=item id + +C is the only required parameter for C. It should be either a +scalar value or an array reference. You specify the ID's of children whose +parents you are looking for. The type of argument (scalar or array ref) affects +the return in the same way as C. + +=item cols + +C works in a similar way to the C parameter to C. You +specify the columns you want in the return as an array ref. What you get back +will have these columns in it. If C is not specified, you'll get back all +columns. + +Note that 'tree_id_fk' and the depth column for the table are required fields +and will be added if not specified. + +=back + +=head2 child_ids + +If you are looking for just the ID's of the children of a particular node, you +should use this. The return value is one of the following, depending on what you +pass in: + +hash reference of array references: + { ID => [ID, ID, ...], ... } +with one ID in the hash reference for each id you specify. The array reference +contains the child ID's of the key ID. + +hash reference of hash references: + { ID => { ID => dist, ID => dist, ... }, ... } +with one ID in the other hash reference for each id you specify. The inner hash +reference is made of child_id => child_distance key-value pairs. + +array reference or hash reference: + [ID, ID, ...] +hash reference: + { ID => dist, ID => dist } + +The first two apply when passing in an array reference for C, the latter two +when passing a scalar value for C. The first and third are without +C specified, the second and fourth occur when you specify +C. + +=over 4 + +=item id + +Like all other accessors, child_ids takes a scalar value or array reference as +the C value. Return as noted above. + +=item include_dist + +This changes the return as noted above - instead of just getting an array +reference of child ID's, you get the child ID's as the keys of a hash reference, +and the distances of the child from the parent you requested as the values. + +=back + +=head2 parent_ids + +Exactly the same as child_ids, except that this works I the tree instead of +I. Takes the same arguments, gives the same possible returns. + +=head1 INDICES + +A tree requires a few indices to get optimal performance out of it. If the table +is never expected to be more than just a few rows, you won't notice a +substantial difference, however, as with any table, as the table grows the +performance proper indexing provides becomes more appreciable. + +Two indices are created automatically on the tree table, one on tree_id_fk, and +the other on tree_anc_id_fk,tree_dist, so you don't need to worry about that +table. + +Obviously, the usage of the tree affects how many indices you want, this section +is simply to provide some general guidelines for the indices required. + +Because the roots_only option is based solely on the main table and not the +tree, if you are using roots_only (calling children with id => 0 automatically +turns on the roots_only option), you want to make sure you have an index on the +root column. If you also use the max_depth depth option, add the depth column to +this index. + +Keep in mind that you may need to mix other columns in here if you are using a +condition with children(). This also applies when using the C and +C parameters - basically you need to figure out what your indices +are, and then add in the root column and, if using max_depth, the depth column. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Tree.pm,v 1.30 2008/06/11 06:55:26 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree/Rebuild.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree/Rebuild.pm new file mode 100644 index 0000000..4ad07a4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree/Rebuild.pm @@ -0,0 +1,237 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::SQL::Table +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# This goes hand in hand with GT::SQL::Tree and is very useful in +# turning an existing table without the root, and/or depth columns +# into a GT::SQL::Tree-compatible format. +# +package GT::SQL::Tree::Rebuild; +# =============================================================== +use strict; +use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/; + +use constants TREE_COLS_ROOT => 0, + TREE_COLS_FATHER => 1, + TREE_COLS_DEPTH => 2; + +@ISA = qw/GT::SQL::Base/; +$DEBUG = 0; +$VERSION = sprintf "%d.%03d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/; +$ERROR_MESSAGE = 'GT::SQL'; + +# New returns a GT::SQL::Tree::Rebuild object when you can pass to GT::SQL::Tree. +# When you are adding a tree to an existing table, but the table does not have +# the root and/or depth columns, you get a Rebuild object, then pass it to +# ->add_tree so that your tree can be built anyway. +# You need to call new with the following options: +# table => $Table_object +# missing_root => sub { ... }, # Only if you are missing the root. The code reference should return the pk of the root. +# missing_depth => 1, # Only if you are missing the depth. The code reference should return the depth of the node. +# missing_father => 1, # Only if you are missing the father. The code reference should return the pk of the father. +# cols => [...], # The columns you want %row (discussed below) to contain +# +# The code references are passed two arguments: +# \%row, # A row from the table. If using the cols option, it will only have those columns. +# $table_object, # This is the same object you pass to new() +# \%all # This is a hash reference of all rows; each key is a primary key, each value the row. This may or may not be of use to you. +# +# For depth, %all will have root and father ids set, for roots father ID's will be set. +# +# NOTE: The father, root, and depth columns must exist beforehand. +sub new { + my $this = shift; + my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new(HASH or HASH REF)'); + + my $self = bless {}, $this; + + $self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ ... table => $table_obj ... })'); + for (qw(missing_root missing_depth missing_father)) { + next unless exists $opts->{$_}; + $self->{$_} = $opts->{$_}; + ref $self->{$_} eq 'CODE' or return $self->error(BADARGS => FATAL => '$obj->new({ ... ' . $_ . ' => sub { ... } ... })'); + } + $self->{cols} = $opts->{cols} if $opts->{cols}; + $self->{cols} = [$self->{cols}] if $self->{cols} and not ref $self->{cols}; + $self->{cols} ||= []; + $self->{order_by} = $opts->{order_by} if $opts->{order_by}; + + $self->{missing_root} or $self->{missing_depth} or $self->{missing_father} or return $self->error(BADARGS => FATAL => 'At least one of "missing_root", "missing_depth", or "missing_father" must be passed to $obj->new({ ... })'); + + $self->{_debug} = $opts->{debug} || $DEBUG || 0; + + $self; +} + +# Called internally by the GT::SQL::Tree object. This does all the calculations. +# Note that this only rebuilds the table itself, GT::SQL::Tree->create will still +# have to create its tree table. +sub _rebuild { + my ($self, $pk, $root_col, $father_col, $depth_col) = @_; + my $table = $self->{table}; + + my $count = $table->count(); + for (my $i = 0; $i < $count; $i += 10000) { + $table->select_options("ORDER BY $self->{order_by}") if exists $self->{order_by}; + $table->select_options("LIMIT 10000" . ($i ? " OFFSET $i" : "")); + my $sth = $table->select(@{$self->{cols}}); + while (my $row = $sth->fetchrow_hashref) { + my %update; + if ($self->{missing_father}) { + my $father_id = $self->{missing_father}->($row, $table); + $update{$father_col} = $father_id unless $row->{$father_col} == $father_id; + $row->{$father_col} = $father_id; + } + if ($self->{missing_root}) { + my $root_id = $self->{missing_root}->($row, $table); + $update{$root_col} = $root_id unless $row->{$root_col} == $root_id; + $row->{$root_col} = $root_id; + } + if ($self->{missing_depth}) { + my $depth = $self->{missing_depth}->($row, $table); + $update{$depth_col} = $depth unless $row->{$depth_col} == $depth; + $row->{$depth_col} = $depth; + } + + $table->update(\%update, { $pk => $row->{$pk} }) if keys %update; # If the new value(s) is/are 0, like the default value(s), %update will be empty + } + } + + return 1; +} + +1; + +__END__ + +=head1 NAME + +GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree. + +=head1 SYNOPSIS + + use GT::SQL::Tree; + use GT::SQL::Tree::Rebuild; + + my $rebuild = GT::SQL::Tree::Rebuild->new( + table => $DB->table('MyTable'), + missing_root => \&root_code, + missing_father => \&father_code, + missing_depth => \&depth_code, + order_by => 'column_name' + ); + + $DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild); + +=head1 DESCRIPTION + +GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and +aids in turning an existing table into one with the neccessary root, father and +depth columns needed by GT::SQL::Tree. + +The main purpose is to do a one-shot conversion of a table to make it compatible +with GT::SQL::Tree. + +=head2 new - Create a Rebuild object + +There is only one method that is called - new. You pass the arguments needed +and get back a GT::SQL::Tree::Rebuild object. This object should then be passed +into GT::SQL::Tree->create (typically via C<$editor-Eadd_tree()>) + +new() takes a hash with up to 4 argument pairs: "table" (required), and one or +more of "missing_root", "missing_father", or "missing_depth". The values are +explained below. + +=over 4 + +=item table + +Required. You specify the table object for the table to rebuild. For example, if +you are going to add a tree to the "Category" table, you provide the "Category" +table object here. + +=item cols + +By default, an entire row will be returned. To speed up the process and lower +the memory usage, you can use the C option, which specifies the columns to +select for $row. It is recommended that you only select columns that you need as +doing so will definately save time and memory. + +=item missing_father, missing_root, missing_depth + +Each of these arguments takes a code reference as its value. The arguments to +the code references are as follows: + +=over 4 + +=item $row + +The first argument is a hash reference of the row being examined. Your job, in +the code reference, is to examine $row and determine the missing value, +depending on which code reference is being called. missing_root needs to return +the root_id for this row; missing_father needs to return the father_id, and the +missing_depth code reference should return the depth for the row. + +=item $table + +The second argument passed to the code references is the same table object that +you pass into new(), which you can select from if neccessary. + +=back + +=item missing_father + +The C code reference is called first - before C +and C. The code reference is called as described above and should +return the ID of the father of the row passed in. A false return (0 or undef) is +interpreted as meaning that this is a root and therefore has no father. + +=item missing_root + +C has to return the root of the row passed in. This is called +after C, so the $row will contain whatever you returned in +C in the father ID column. Of course, this only applies if using +both C and C. + +=item missing_depth + +C has to return the depth of the row passed in. This is called +last, so if you are also using C and/or C, you +will have whatever was returned by those code refs available in the $row. + +=item order_by + +The query done to retrieve records can be sorted using the C option. +It should be anything valid for "ORDER BY _____". Often it can be useful to have +your results returned in a certain order - for example: + order_by => 'depth_column ASC' +would insure that parents come before roots. Of course, this example wouldn't +work if you are using "missing_depth" since none of the depth values will be +set. + +=back + +Once you have a GT::SQL::Tree::Rebuild object, you should pass it into +Ccreate> (which typically involves passing it into +C<$editor-Eadd_tree()>, which passed it through). Before calculating the +tree, GT::SQL::Tree will call on the rebuild object to reproduce the father, +root, and/or depth columns (whichever you specified). + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Types.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Types.pm new file mode 100644 index 0000000..605c7df --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Types.pm @@ -0,0 +1,384 @@ +1; + +__END__ + +=head1 NAME + +GT::SQL::Driver::Types - Column types supported by GT::SQL + +=head1 SYNOPSIS + + my $c = $DB->creator('new_table'); + $c->cols({ + column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 } + # ... more columns ... + }); + + my $e = $DB->editor('table_name'); + $e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' }); + +=head1 DESCRIPTION + +This module should not be used directly, however the documentation here +describes the different types support by GT::SQL and any caveats associated +with those types. + +=head1 ATTRIBUTES + +All types are specified as a C { column definition }> pair, +where the column definition should contain at least a C key containing +one of the L outlined below. Commonly accepted attributes are: + +=over 4 + +=item not_null + +Used to specify that a column should not be allowed to contain NULL values. +Note that for character/string data types, a 0-character string (and, for +C/C columns, strings containing only spaces), B considered +NULL values are are not permitted if the column is specified as C. +The value passed to not_null should be true. + +=item default + +Used to specify a default value to be used for the column when no explicit +value is provided when a row is inserted. The default value is also used for +the value in existing rows when adding a not_null column to an existing table - +in such a case, the C is B. + +Also see the L|/TEXT> section regarding caveats and limitations of +using C's for C types. + +=back + +Other column attributes are supported as outlined below. In addition to +attributes mentioned in this document, various attributes are available that +influence automatically-generated forms displayed by GT::SQL::Admin - see +L for details on these attributes. + +=head1 TYPES + +=head2 Integer types + +=over 4 + +=item TINYINT + +The C type specifies an 8-bit integer able to handle values from -128 +to 127. Some databases will allow larger values due to not supporting an +appropriate data type. The C column attribute I turn this into +an unsigned value supporting values from 0 to 255; due to this type being +implemented as a larger integer type in some databases (which, incidentally, +coincide with the databases not supporting an unsigned 8-bit C) using +an C TINYINT type will result in a column able to store any value +from 0-255, unlike most of the larger integer types below. + +=item SMALLINT + +The C type specifies a 16-bit integer able to handle values from +-32768 to 32767. The C column attribute I turn this into an +unsigned value supporting values from 0 to 65535, however this is B +guaranteed. If you need to store values in the 32768-65535 range, a larger +type is recommended. + +=item MEDIUMINT + +The C type (only natively supported by MySQL) specifies a 24-bit +integer type able to hold values from -8388608 to 8388607. If the C +column attribute is specified, this allows values from 0 to 16777215. Due to +this being supported with the C attribute, or implemented as a larger +data type, an C C will always supported values up to +16777215. + +=item INT, INTEGER + +The C type specifies a 32-bit integer able to hold values from -2147483648 +to 2147483647. If the C column attribute is specified, the column +I support values from 0 to 4294967295, however this is B guaranteed. +If values larger than 2147483647 are needed, using the C type below is +recommended. C is an alias for C. + +=item BIGINT + +The largest integral type, C specifies a 64-bit integer value able to +hold values from -9223372036854775808 to 9223372036854775807. If specified as +C, the column I support values from 0 to 18446744073709551616, +but this is B guaranteed. If larger values are needed, use the C +type with a C value of C<0>. + +=back + +=head2 Float-point types + +=over 4 + +=item REAL, FLOAT + +The C type specifies a 32-bit floating-point (i.e. fractional) number, +accurate to 23 binary digits (which works out to I 6 decimal +digits). The values may be signed, and can range from at least as small as +10^-37 to at least as large as 10^37. For more precise values, the C +type is recommended. For exact precision (i.e. for monetary values), the +(often slower) C type is recommended. C is an alias for +C. + +=item DOUBLE + +The C type specifies a 64-bit floating-point (i.e. fractional) number, +accurate to 52 binary digits (I 15 decimal digits). The values +may be signed, and can range from at least as small as 10^-307 to at least as +large as 10^308 (except under Oracle - see below). For exact precision (i.e. +for monetary values), the (often slower) C type is recommended. + +Take note that Oracle doesn't properly support the full range supported by +other databases' C types - the smallest number supported (assuming +precision to digits) is 10^-113 - specifically, the number of digits after the +decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while +1.23456789012e-117 is not. The larger number Oracle supports is just less than +1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you +need to store numbers larger or smaller than this amount, you'll have to find +some other way to store your numbers (i.e. Math::BigFloat with a C). + +=back + +=head2 Aribtrary precision numbers + +=over 4 + +=item DECIMAL + +The C type is provided to support numbers of arbitrary precision. It +requires two attributes, C and C, where C specifies +the number of decimal places, and precision specifies the number of overall +digits. For example, C<123.45> has a C of 5, and a C of 2. +C<42> has a C or 2, and a C of 0. C must be less than +C, and C must not exceed 38. Also, although the value +stored and retrieved is completely accurate within it's given precision and +scale range, the accuracy available for comparisons (i.e. column = number) is +only reliably accurate to approximately the same level as DOUBLE's - that is, +about 15 digits. + +=back + +=head2 Character types + +=over 4 + +=item CHAR + +The C type is used to specify a string of characters from 1 to 255 +characters long. It takes a C attribute which must be 255 or less, and +specifies the size of the column values - if not specified, 255 will be used. +This implementation's C type, for historic reasons, B pad +inserted values with spaces, but B trim trailing spaces when retrieving +and/or comparing values. Note that this is B SQL compliant C +behaviour - SQL-compliant C's are padded with spaces up to their size. + +What this ends up meaning is that for everything except MySQL, C columns +will be mapped to C columns. Note that even MySQL, which is the only +database for which C's are not automatically mapped into C's, +will I convert C columns to C columns if any +non-fixed-size datatype (anything other than a C or numeric types) is +used in or added to the table. As a general rule, C is preferred over +C except when dealing with columns whose values don't vary significantly +in length B are in a table that only contains fixed-size data types +(C's and numeric types). Everywhere else, use C's, since that's +what you'll be getting anyway. + +A C attribute is supported, which I indicates that comparisons +with this field should be case-sensitive. Note that this only works on +databases that actually have a case-sensitive C field - currently, only +MySQL. + +=item VARCHAR + +The C type is identical to the above C type B as +follows. Unlike a C, a C column does not take up C bytes +of storage space - typically the storage space is only slightly larger +(typically 1 byte) than the size of the value stored. As such, C's +are almost always preferred over columns, except for nearly-constant sized +data, or tables with all fixed-width data types (C's, C's, and +non-C numeric types). C columns will not be padded with +whitespace up to C, however trailing whitespace C be trimmed from +values. + +As with C, the C attribute I make the C values +case-sensitive for the matching purposes. + +=item TEXT + +The C type is similar to C types, except that they are always +case-insensitive for matching/equality, and can contain longer values. The +C type takes a C attribute which contains the length required - if +not provided, a value of approximately 2 billion is used. Note that the +maximum size of the column will usually be larger than the value you specify to +C - it simply indicates to the driver to use a field capable of at least +the size specified. The values of C fields are case-insensitive in terms +of matches and equality. The maximum C value, and the default, is +approximately 2 billion. + +Certain aliases are provided with implicit size defaults - C, +C, C, and C, which are equivelant to C +with C values of 255, 65535, 16777215, and 2147483647, respectively. + +Depending on the C value, certain databases _may_ use different +underlying types. MySQL, for example, uses the smallest possible type between +its native C, C, C, and C types. As +such, it is recommended that you use a sufficiently large C value unless +absolutely sure that you will never need a larger value. + +Also note that C types B support normal equality operations - in +fact, the only portable things that can be done with C columns is C tests (in GT::SQL this means "=" C) and C comparisons - but, +for portability with all supported databases, the argument of a C may not +exceed 4000 characters. + +Also note that the C value will be ignored by MySQL, which does not +support having default values on C columns. Everything else, however, +will properly support this, and the default will still be used when inserting +with GT::SQL even when using MySQL. Also note that the default value of +C types B exceed 3998 characters, due to limits imposed by some +databases. Longer indexes may work in some cases, but are not guaranteed - for +example, a table resync on MSSQL will not work. + +=item ENUM + +The C type is a MySQL-only type that supports certain fixed string +values. On non-MySQL databases, it is simply mapped to a C column. +It requires a C option which should have a value of an array reference +of string values that the ENUM should permit. The C type is generally +discouraged in favour of a C, C, or an +L column, all of which provide more flexibility +(i.e. if you want to add a new possible value) and are not a single +database-specific type. + +=back + +=head2 Date/time types + +All of the date/time types support by MySQL will be handled by GT::SQL, for +compatibility reasons. However, all types other than DATE and C +should be considered deprecated as cross-database compatibility is not possible +using these types. In particular, C will work exactly like a +C on every non-MySQL database; C
        ~; + for my $key (sort keys %$tags) { + my $val = $tags->{$key}; + $val = $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE'; + $val = $dumper->dump(data => $val) if ref $val; + $val = GT::CGI::html_escape($val); + local $^W; + $val =~ s/ / /g; + $val =~ s|\n|
        \n|g; + if ((not exists $opts{-hide_long} or $opts{-hide_long}) and (my $num_lines = $val =~ y/\n//) > 26) { + my $id = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 0 .. 24]; + my $more_lines = $num_lines - 25; + $val =~ s{^((?:.*\n){25})}{$1($more_lines more lines)"; + } + $output .= qq|"; + } + $output .= qq~
        <$font>Available Variables
        <$font>$key| . (length $val ? qq|$val| : ' ') . "
        ~; + } + return \$output; +} +END_OF_SUB + +sub _parse { +# --------------------------------------------------------------- +# Sets the parsing options, and gets the code ref and runs it. +# + my ($self, $template, $opt) = @_; + + my $compress = exists $opt->{compress} ? $opt->{compress} : $self->{compress}; + local $self->{opt} = {}; + $self->{opt}->{strict} = exists $opt->{strict} ? $opt->{strict} : $self->{strict}; + $self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print}; + $self->{opt}->{escape} = exists $opt->{escape} ? $opt->{escape} : $self->{escape}; + $self->{opt}->{package} = exists $opt->{package} ? $opt->{package} : caller(1) || 'main'; + $self->{opt}->{func_code} = exists $opt->{func_code} ? $opt->{func_code} : $self->{func_code}; + $self->{opt}->{heap} = exists $opt->{heap} ? $opt->{heap} : $self->{heap}; + +# Set the root if this is a full path so includes can be relative to template. + if (substr($template, 0, 1) eq '/' or substr($template, 1, 1) eq ':') { + $self->{root} = substr($template, 0, rindex($template, '/')); + substr($template, 0, rindex($template, '/') + 1) = ''; + } + my $root = $self->{root}; + my $full_file = $self->{root} . '/' . $template; + my ($code, $dont_save, $files) = $self->{opt}->{print} == 2 + ? @{$FILE_CACHE_PRINT{$full_file}}{qw/code dont_save files/} + : @{$FILE_CACHE{$full_file}}{qw/code dont_save files/}; + + # Determine the newest mtime from the cache info; this won't be accurate + # until the template is completely parsed due to dynamic includes (which + # may be used without your knowledge as an optimization). + for (@$files) { + my $mtime = $_->[2]; + $self->{mtime} = $mtime if $mtime and (!$self->{mtime} or $self->{mtime} < $mtime); + } + + my $output = $code->($self); + return $output if $self->{opt}->{print} == 2; + + $LAST_MODIFIED = $self->{mtime}; + +# Compress output if requested. + if ($compress) { + $self->debug("Compressing output for template '$template'.") if $self->{_debug}; + + my ($pre_size, $post_size); + $pre_size = length $$output if $self->{_debug}; + $self->_compress($output); + $post_size = length $$output if $self->{_debug}; + + $self->debug(sprintf "Output reduced %.1f%%. Size before/after compression: %d/%d.", 100 * (1 - $post_size / $pre_size), $pre_size, $post_size) if $self->{_debug}; + } + return $$output; +} + +$COMPILE{_compile_template} = __LINE__ . <<'END_OF_SUB'; +sub _compile_template { +# ------------------------------------------------------------------- +# Loads the template parser and compiles the template and saves it +# to disk. +# + my ($self, $file, $full_compiled, $print) = @_; + $self->debug("Compiling template $file (into $full_compiled)") if $self->{_debug}; + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + + my ($code, $files) = $parser->parse( + $file, + { + root => $self->{root}, + include_root => $self->{include_root} + }, + ($print and $print == 2) + ); + + local *FH; + my $tmpfile = $full_compiled . "." . time . "." . $$ . "." . int(rand(10000)) . ".tmp"; + open FH, ">$tmpfile" or return $self->fatal(CANTOPEN => $tmpfile, "$!"); + my $localtime = localtime; + my $file_string = '[' . join(',', map { + my ($file, $path, $mtime, $size) = @$_; + for ($file, $path) { s/([\\'])/\\$1/g if defined } + "['$file'," . (defined $path ? "'$path'" : 'undef') . ",$mtime,$size]" + } @$files) . ']'; + + (my $escaped = $full_compiled) =~ s/(\W)/sprintf "_%x", ord($1)/ge; + print FH qq +|# This file is a compiled version of a template that can be run much faster +# than reparsing the file, yet accomplishes the same thing. You should not +# attempt to modify this file as any changes you make would be lost as soon as +# the original template file is modified. +# Editor: vim:syn=perl +# Generated: $localtime, using GT::Template::Parser v$GT::Template::Parser::VERSION +local \$^W; +{ + files => $file_string, + parser_version => $VERSION, + code => \\>::Template::parsed_template +}; +sub GT::Template::parsed_template { +$$code +}|; + close FH; + unless (rename $tmpfile, $full_compiled) { + unlink $tmpfile; + return $self->fatal(RENAME => $tmpfile, $full_compiled, "$!"); + } + chmod 0666, $full_compiled; + return; +} +END_OF_SUB + +$COMPILE{_compile_string} = __LINE__ . <<'END_OF_SUB'; +sub _compile_string { +# ----------------------------------------------------------------------------- +# Like _compile_template, except that this returns a code reference for the +# passed in string. +# Takes two arguments: The string, and print mode. If print mode is on, the +# code will print everything and return 1, otherwise the return will be the +# result of the template string. + my ($self, $string, $print) = @_; + $self->debug("Compiling string '$string' in " . (($print and $print == 2) ? "stream mode" : "return mode")) if $self->{_debug}; + if (!$string) { + $self->debug("Actual parsing skipped for empty or false string '$string'") if $self->{_debug}; + if ($print and $print == 2) { + return sub { print $string }; + } + else { + return sub { \$string }; + } + } + + require GT::Template::Parser; + my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); + $parser->debug_level($self->{_debug}) if $self->{_debug}; + my ($eval) = $parser->parse( + $string, + { + root => $self->{root}, + include_root => $self->{include_root}, + string => $string + }, + ($print and $print == 2) + ); + + my $code; + local ($@, $^W); + eval { # Catch tainted data + eval "sub GT::Template::parsed_template { $$eval }"; + $code = \>::Template::parsed_template unless $@; + }; + + unless (ref $code eq 'CODE') { + return $self->fatal(CANTRUNSTRING => "sub GT::Template::parsed_template { $$eval }", "$@"); + } + return $code; +} +END_OF_SUB + +$COMPILE{_call_func} = __LINE__ . <<'END_OF_SUB'; +sub _call_func { +# ----------------------------------------------------------------------------- +# Calls a function. The arguments are set in GT::Template::Parser. If the +# function returns a hash, it is added to $self->{VARS} _unless_ the 'set' +# option is provided and true. The result of the function is escaped, if +# escape mode is turned on. +# + my ($self, $torun, $allow_strict, $set, @args) = @_; + my $aliased; + if (exists $self->{ALIAS}->{$torun}) { + $torun = $self->{ALIAS}->{$torun}; + $aliased = 1; + } + no strict 'refs'; + my $rindex = rindex($torun, '::'); + my $package; + $package = substr($torun, 0, $rindex) if $rindex != -1; + my ($code, $ret); + my @err = (); + my $ok = 0; + if ($package) { + my $disabled; + if ($aliased) { + if ($self->{disable}->{alias_args} and @args) { + $disabled = $ERRORS->{DISABLED_ALIASARGS}; + } + } + elsif ($self->{disable}->{functions}) { + $disabled = $ERRORS->{DISABLED_FUNC}; + } + elsif ($self->{disable}->{function_args} and @args) { + $disabled = $ERRORS->{DISABLED_FUNCARGS}; + } + elsif ($self->{disable}->{function_restrict} and $torun !~ /$self->{disable}->{function_restrict}/) { + $disabled = sprintf $ERRORS->{DISABLED_FUNCRE}, $torun; + } + + if ($disabled) { + push @err, $disabled; + } + else { + my $func = substr($torun, rindex($torun, '::') + 2); + (my $pkg = $package) =~ s,::,/,g; + until ($ok) { + local ($@, $SIG{__DIE__}); + my $req = eval { require "$pkg.pm" }; + if (!$req) { + push @err, $@; + # Remove file from %INC so that future require's don't succeed: + delete $INC{"$pkg.pm"}; + } + elsif (defined(&{$package . '::' . $func}) + or defined &{$package . '::AUTOLOAD'} and %{$package . '::COMPILE'} and exists ${$package . '::COMPILE'}{$func} + ) { + $ok = 1; + $code = \&{$package . '::' . $func}; + last; + } + else { + push @err, sprintf($ERRORS->{NOSUB}, "$package\::$func", "$pkg.pm"); + } + my $pos = rindex($pkg, '/'); + $pos == -1 ? last : (substr($pkg, $pos) = ""); + last unless $self->{pkg_chop}; + } + } + } + elsif (ref $self->{VARS}->{$torun} eq 'CODE') { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun}; + $ok = 1; + } + } + elsif ($self->{DELAY_VARS}->{$torun}) { + if ($self->{disable}->{coderef_args} and @args) { + push @err, $ERRORS->{DISABLED_CODEARGS}; + } + else { + $code = $self->{VARS}->{$torun} = $self->{DELAY_VARS}->{$torun}->{$torun}; + delete $self->{DELAY_VARS}->{$torun}; + $ok = 1; + } + } + elsif ($CORE{$torun}) { + if ($self->{disable}->{core_functions}) { + push @err, $ERRORS->{DISABLED_COREFUNCS}; + } + else { + $code = $CORE{$torun}; + $ok = 1; + } + } + + if ($ok) { + local $PARSER = $self; + if ($self->{opt}->{heap}) { + push @args, $self->{opt}->{heap} + } + if ($package and ref($self->{opt}->{func_code}) eq 'CODE') { + $ret = $self->{opt}->{func_code}->($torun, @args); + } + else { + $ret = $code->(@args); + } + if (ref $ret eq 'HASH' and not $set) { + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + $ret = ''; + } + } + elsif ($package) { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{CANTLOAD}, $package, join(",
        \n", @err)) : ''; + } + else { + if (@err) { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{CANTCALLCODE}, $torun, join(",
        \n", @err)) : ''; + } + else { + $ret = ($allow_strict and $self->{opt}->{strict}) ? \sprintf($ERRORS->{NOTCODEREF}, $torun) : ''; + } + } + + $ret = '' if not defined $ret; + $ret = (ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE') ? $$ret : ($set and ref $ret) ? $ret : $self->{opt}->{escape} ? GT::CGI::html_escape($ret) : $ret; + return $ret; +} +END_OF_SUB + +$COMPILE{_compress} = __LINE__ . <<'END_OF_SUB'; +sub _compress { +# ----------------------------------------------------------------------------- +# Compress html by removing extra space (idea/some re from HTML::Clean). +# Avoids compressing pre tags. +# + my ($self, $text) = @_; + if ($$text =~ /))( + my $html = $1; + my $pre = $2 || ''; + $html =~ s/\s+\n/\n/g; + $html =~ s/\n\s+\s{2,} />/g; + $html =~ s/<\s+/\s{2,} />/g; + $$text =~ s/<\s+/ $_[2], strict => $_[3] } if not ref $opt and defined $opt; + + $opt ||= { escape => 0, strict => 0 }; + $opt->{merge} = 1 if not exists $opt->{merge}; + $opt->{return_ref} = 0 unless $opt->{return_ref}; + + my ($ret, $good) = ('', 1); + if (ref($str) eq 'HASH') { + $ret = $str; + } + elsif (exists $self->{ALIAS}->{$str}) { + $ret = $self->_call_func($str); + } + elsif (my ($val) = $self->_raw_value($str)) { + if (ref $val eq 'CODE') { + local $PARSER = $self; + $ret = $val->($self->vars, $self->{opt}->{heap} || ()); + + $ret = '' if not defined $ret; + } + else { + $ret = $val; + $ret = '' if not defined $ret; + } + } + elsif ($str eq 'TIME') { + return time; + } + else { + $good = 0; + } + + if (not $good) { + return $opt->{strict} ? sprintf($ERRORS->{UNKNOWNTAG}, $str) : undef; + } + if ($opt->{return_ref} and (ref $ret eq 'HASH' or ref $ret eq 'ARRAY')) { + return $ret; + } + if (ref $ret eq 'HASH') { + return 1 if not $opt->{merge}; + my $tags = $self->vars; + @$tags{keys %$ret} = values %$ret; + return; + } + return if not defined $ret; + return $$ret if ref $ret eq 'SCALAR' or ref $ret eq 'LVALUE'; + return $ret if not $opt->{escape}; + $ret =~ s/&/&/g; + $ret =~ s//>/g; + $ret =~ s/"/"/g; + return $ret; +} + +sub _raw_value { +# ----------------------------------------------------------------------------- +# Gets a raw value. If the variable doesn't exist, returns an empty list (or +# undef, in scalar context). +# + my ($self, $key) = @_; + if (exists $self->{VARS}->{$key} and $self->{DELAY_VARS}->{$key}) { + $self->{VARS}->{$key} = $self->{DELAY_VARS}->{$key}->{$key}; + delete $self->{DELAY_VARS}->{$key}; + } + return $self->{VARS}->{$key} if exists $self->{VARS}->{$key}; + return time if $key eq 'TIME'; + + if ($key =~ /^\w+(?:\.\$?\w+)+$/) { + my $cur = $self->{VARS}; + my @k = split /\./, $key; + for (my $i = 0; $i < @k; $i++) { + if ($k[$i] =~ /^\$/) { + my $val = $self->_get_var(substr($k[$i], 1)); + $val = '' if not defined $val; + my @pieces = split /\./, $val; + @pieces = '' if !@pieces; + splice @k, $i, 1, @pieces; + $i += @pieces - 1 if @pieces > 1; + } + } + KEY: while (@k) { + # for a.b.c: + # @k = ('a', 'b', 'c') + # @i = ('a.b.c', 'a.b', 'a') + # This is needed because "a.b.c" will look for key "b.c" in hash "a" before key "b" + my @i = map join('.', @k[0 .. $_]), reverse 1 .. $#k; + push @i, shift @k; + + { + if (ref $cur eq 'CODE') { + # current node (e.g. a.b for a.b.c) is a code ref; call it, and try again + $cur = $cur->($self->{opt}->{heap} || ()); + redo; + } + elsif (ref $cur eq 'ARRAY' and $i[-1] =~ /^\d+$/) { + return if $i[-1] > $#$cur; + $cur = $cur->[$i[-1]]; + } + elsif (ref $cur eq 'ARRAY' and $i[-1] =~ /^last(\d+)?$/) { + my $negi = $1 || 1; + return if $negi > @$cur; + $cur = $cur->[-$negi]; + } + elsif (!@k and ref $cur eq 'ARRAY' and $i[0] eq 'length') { + $cur = scalar @$cur; + } + elsif (ref $cur eq 'HASH' or UNIVERSAL::isa($cur, 'GT::Config')) { + my $exists; + for (0 .. $#i) { + if (exists $cur->{$i[$_]}) { + splice @k, 0, $#i-$_ unless $_ == $#i; + $cur = $cur->{$i[$_]}; + $exists = 1; + last; + } + } + return unless $exists; + } + elsif (UNIVERSAL::can($cur, 'param') and my ($val) = $cur->param($i[0])) { + $cur = $val; + last KEY; + } + else { + return; + } + } + } + + return $cur; + } + + return; +} + +sub _include { +# ----------------------------------------------------------------------------- +# Perform a runtime include of a file. +# + my ($self, $template, $allow_path) = @_; + + $allow_path = $self->{varinc_allow_path} unless defined $allow_path; + + if ($template eq '.' or $template eq '..' or ($template =~ m{[/\\]} and !$allow_path)) { + return sprintf $ERRORS->{BADINC}, $template, 'Invalid characters in filename'; + } + + if (++$self->{include_safety} > GT::Template::INCLUDE_LIMIT) { + return $ERRORS->{DEEPINC}; + } + + if ($allow_path and $self->{include_root} and $template =~ m{^(?:[a-zA-Z]:)?[/\\]}) { + # Remove the drive letter on Windows + $template =~ s/^[a-zA-Z]://; + $template = $self->{include_root} . $template; + +# A small (hopefully temporary) hack to fix the problem where the compiled +# files end up in the included template's directory. + if ($self->{root}) { + $template =~ s|^\Q$self->{root}\E[/\\]||; + } + } + + my $opt = $self->{opt}; + my $print = $self->{print}; + my $streaming = $print && $print == 2; + $self->load_template($template, $streaming ? 2 : 0) unless $self->{skip_mod_check}->{$template}++; + + $self->debug("Parsing dynamic include '$template' with (print => @{[$opt->{print}||0]}, compress => @{[$opt->{compress}||0]}, strict => @{[$opt->{strict}||0]}, escape => @{[$opt->{escape}||0]})") if $self->{_debug}; + + my $ret = $self->_parse($template, $opt); + + --$self->{include_safety}; + + return $streaming ? '' : $ret || ''; +} + +1; + +__END__ + +=head1 NAME + +GT::Template - Gossamer Threads template parser + +=head1 SYNOPSIS + + use GT::Template; + my $var = GT::Template->parse('file.txt', { key => 'value' }); + ... + print $var; + +or + + use GT::Template; + GT::Template->parse_print('file.txt', { key => 'value' }); + +or + + use GT::Template; + GT::Template->parse_stream('file.txt', { key => 'value' }); + +or + + use GT::Template; + my $parser = GT::Template->new; + $parser->parse('file.txt', { key => 'value' }); + +=head1 DESCRIPTION + +GT::Template provides a simple way (one line) to parse a template (which +can be either a file or a string) and make sophisticated replacements. + +It supports simple replacements, conditionals, function calls, including other +templates, and more. + +Additionally, through using pre-compiled files, subsequent parses of a template +will be very fast. + +=head2 Template Syntax + +The template syntax documentation has moved - it is now documented in +L. + +=head2 parse + +This option parses a template, and returns the value of the parsed template. +See L for a description of the possible parse parameters. + +=head2 parse_print + +This option parses a template, and prints it. See L for a +description of the possible parse_print parameters. + +=head2 parse_stream + +This option parses a template, and prints each part of it as the parse occurs. +It should only be used in situations where streaming content is required as it +is measurably slower than the parse_print alternative. See L +for a description of the possible parse_stream parameters. + +=head2 Parse Options + +=head3 Filename + +The first argument to parse()/parse_print()/parse_stream() (hereafter referred +to simply as parse()) is the full or relative (to the current working +directory) path to the file to parse. + +=head3 Variables + +The second argument is a hash reference of template variables that will be +available in the parsed template (see L). Arbitrary +hash/array data structure access is supported (see +L). + +Loops are supported by providing an array reference or code reference as a +value; array reference loops are generally preferred as they enable the loop to +be used multiple times and support the <%loopvar.length%> syntax. + +=head3 Options + +The third argument (which is not required) takes additional options that change +the way a parse is performed. The available options (there are more, however +their use is discouraged) are as follows. + +=over 4 + +=item * string => $template + +Passing in C $template> will use $template as for the template +content instead of reading the file specified as the first parse() argument. +If provided, the first argument to parse() (the filename) is ignored. + +=item * compress => 1 + +Setting compress => 1 will compress all white space generated by the program. +This is usually acceptable for HTML, reducing page sizes by typically 10-20%, +but should not be used for non-HTML templates. The default is 0 (no +compression). This option has no effect when using parse_stream(). + +=item * strict => 0 + +If set to 1, attempting to use a tag that does not exist will display an +"Unknown tag 'tagname'" error. If strict is set to 0, using an unset tag will +not display anything. + +=item * escape => 1 + +If enabled, this option will cause all variables to be HTML escaped before +being included on a page. Enabling this option is strongly recommended. +all variables before they are printed. Tag values that should not be escaped +should be passed as scalar references (\$foo or \''). + +This option currently defaults to 0, but may eventually change to 1 - so +passing an explicit 1 or 0 value is strongly recommended. + +=item * disable => { ... } + +This can be used to disable certain GT::Template functionality. To disable a +particular feature, the hash reference passed to disable should contain a +C with a C<1> value, unless otherwise indicated. Feature names +are as follows: + +=over 4 + +=item * functions + +This can be used to disable Package::function calls, such as +C%Some::Package::function%E>. Note, however, that this does _not_ +disable aliased function calls (see below). + +=item * function_args + +This disables any function calls that specify arguments - for instance, +C%Some::Package::function(1)E>. Note that this does _not_ disable +passing arguments to aliased function calls (see below). + +=item * function_restrict + +This can be used to restrict function calls by limiting the available +functions. It takes a regular expression as an argument, which will be tested +against the fully qualified function name - any function that does not match +the regular expression will not be called. For example, to only allow +functions in 'Package::One' and 'Second::Package' to be called, you could use: + + function_restrict => '^(?:Package::One|Second::Package)::\w+$' + +Like the above options, this does not restrict aliased function calls. + +=item * coderefs_args + +This can be specified to disable the calling of code reference variables with +arguments. Tags such as C%coderefname%E> and +C%coderefname()%E> will be allowed, but C%coderefname(1)%E> +will not. + +=item * alias_args + +This option can be used to disable the passing of arguments to aliased function +calls (see below). + +=item * core_functions + +Disables the use of core perl function wrappers such as substr and sprintf. + +=back + +=item * pkg_chop + +When calling a function such as <%Package::A::B::function%>, GT::Template will +first attempt to load Package/A/B.pm, then, if it fails, Package/A.pm, and so +on down to Package.pm, looking for Package::A::B::function in each file. This +behaviour is slow and often undesirable - it is recommended to properly split +up packages (that is, putting Package::A::B inside Package/A/B.pm instead of +Package/A.pm or Package.pm). The "package chopping" occurs if pkg_chop is set +to 1 (currently the default, but may change), and does not occur if pkg_chop is +set to 0 (recommended, but not the default for historic reasons). + +=item * heap + +If this is set, it will be added to the end of any other arguments passed to +functions called. + +=item * func_code + +When calling a function such as <%Package::function%>, you can override the +default behaviour of simply calling the function by providing a code reference +to C. Instead of calling Package::function(), your code reference +will be called with the string of the package to call (e.g. +'Package::function') and the arguments that would have been passed to the +function. The return value of your code will be used as if it was the return +value from the real function. + +=item * begin + +=item * end + +C and C can be used to change the characters that start and end a +template tag. These default to C%> for C, and C<%E> for +C. For example, if you changed C to C<[*> and C to C<*]>, you +would use C<[*tagname*]> for a normal tag, C<[*-- comment --*]> for a comment, +etc. + +=item * varinc_allow_path => 0 + +If enabled, this option will allow paths to be used in variable based includes. + +=back + +=head3 Aliases + +The forth option to parse is an optional hash of aliases to set up for +functions. The key should be the alias name and the value should be the +function to call when the alias is invoked. For example: + + print GT::Template->parse( + 'file.htm', + { key => 'value' }, + { compress => 1 }, + { myfunc => 'Long::Package::Name::To::myfunc' } + ); + +Now in your template you can do: + + <%myfunc('argument')%> + +Which will call C. + +=head2 vars + +Accessing variables from outside a template can be done by calling the +Cvars> method. For further details, please see +L. + +=head2 last_modified + +It is sometimes desirable to know the last modification date of a parsed +template (including includes). For this, the last_modified() method can be +used, subject to some caveats: + +=over 4 + +=item * Does not indicate that the page has not changed - it only indicates +that the I (and both static and dynamic includes) on the page have +not changed, not the output which can, of course, be affected by template +variables. In order to use this for determining the last modified time of an +output template, you need to combine this value with a last-modified date for +the data being provided as template variables. + +=item * Is only valid after the parse has finished. If the value is needed +before the output is printed (e.g. for an HTTP header), neither parse_print() +nor parse_stream() can be used. + +=item * Does not work with string parsing. There is no logical last-modified +time for strings aside from "now", so it is not calculated. + +=back + +=head1 EXAMPLES + +Parse the string contained in $template, making the 'key' tag available. + + my $parsed = GT::Template->parse(undef, { key => 'value' }, { string => $template }); + +Parse file.txt, compress the result, and print it. This is equivelant to +Cparse(...)>, but slightly faster. + + GT::Template->parse_print('file.txt', { key => 'value' }, { compress => 1 }); + +Print the output of the template it as it is parsed, not after entirely parsed. +This will output the same as the above command would without the "compress" +option, but is slower (unless, of course, streaming is needed). + + GT::Template->parse_stream('file.txt', { key => 'value' }); + +Don't display warnings on invalid keys: + + GT::Template->parse_print('file.txt', { key => 'value' }, { strict => 0 }); + +=head1 SEE ALSO + +L - Documentation/tutorial for GT::Template template +tags. + +L - Interface for accessing/manipulating template tags from +Perl code. + +L - Documentation for GT::Template template +inheritance. + +=head1 COPYRIGHT + +Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: Template.pm,v 2.172 2011/05/13 23:56:51 brewt Exp $ + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/GT/Template/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Template/Editor.pm new file mode 100644 index 0000000..370ba90 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/GT/Template/Editor.pm @@ -0,0 +1,417 @@ +# ==================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Template::Editor +# Author: Alex Krohn +# CVS Info : 087,071,086,086,085 +# $Id: Editor.pm,v 2.20 2009/05/09 17:28:30 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ==================================================================== +# +# Description: +# A module for editing templates via an HTML browser. +# + +package GT::Template::Editor; +# =============================================================== +use strict; +use GT::Base; +use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS); +@ISA = qw/GT::Base/; +$VERSION = sprintf "%d.%03d", q$Revision: 2.20 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0; +$ATTRIBS = { + cgi => undef, + root => undef, + backup => undef, + default_dir => '', + default_file => '', + date_format => '', + class => undef, + skip_dir => undef, + skip_file => undef, + select_dir => 'tpl_dir', + demo => undef +}; +$ERRORS = { + CANTOVERWRITE => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.", + CANTCREATE => "Unable to create new files in directory %s. Please set permissions properly and save again.", + CANTMOVE => "Unable to move file %s to %s: %s", + CANTMOVE => "Unable to copy file %s to %s: %s", + FILECOPY => "File::Copy is required in order to make backups.", +}; + +sub process { +# ------------------------------------------------------------------ +# Loads the template editor. +# + my $self = shift; + + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || ''; + my $tpl_text = ''; + my $error_msg = ''; + my $success_msg = ''; + my ($local, $restore) = (0, 0); + +# Check the template directory and file + if ($selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..') { + $error_msg = "Invalid template directory $selected_dir"; + $selected_dir = ''; + $selected_file = ''; + } + if ($selected_file =~ m[[\\/\x00-\x1f]]) { + $error_msg = "Invalid template $selected_file"; + $selected_dir = ''; + $selected_file = ''; + } + +# Create the local directory if it doesn't exist. + my $tpl_dir = $self->{root} . '/' . $selected_dir; + my $local_dir = $tpl_dir . "/local"; + if ($selected_dir and ! -d $local_dir) { + mkdir($local_dir, 0777) or return $self->error('MKDIR', 'FATAL', $local_dir, "$!"); + chmod(0777, $local_dir); + } + my $dir = $local_dir; + + my $save = $self->{cgi}->param('tpl_name') || $self->{cgi}->param('tpl_file'); +# Perform a save if requested. + if ($self->{cgi}->param('saveas') and $save and !$self->{demo}) { + $tpl_text = $self->{cgi}->param('tpl_text'); + if (-e "$dir/$save" and ! -w _) { + $error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $save); + } + elsif (! -e _ and ! -w $dir) { + $error_msg = sprintf($ERRORS->{CANTCREATE}, $dir); + } + else { + if ($self->{backup} and -e "$dir/$save") { + $self->copy("$dir/$save", "$dir/$save.bak"); + } + local *FILE; + open (FILE, "> $dir/$save") or return $self->error(CANTOPEN => FATAL => "$dir/$save", "$!"); + $tpl_text =~ s/\r\n/\n/g; + print FILE $tpl_text; + close FILE; + chmod 0666, "$dir/$save"; + $success_msg = "File has been successfully saved."; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$save"; + $selected_file = $save; + $tpl_text = ''; + } + } +# Delete a local template (thereby restoring the system template) + elsif (my $restore = $self->{cgi}->param("restore") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$restore", "$dir/$restore.bak")) { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!"; + } + } + else { + if (unlink "$dir/$restore") { + $success_msg = "System template '$restore' restored"; + } + else { + $error_msg = "Unable to remove $dir/$restore: $!"; + } + } + } +# Delete a local template (This is like restore, but happens when there is no system template) + elsif (my $delete = $self->{cgi}->param("delete") and !$self->{demo}) { + if ($self->{backup}) { + if ($self->move("$dir/$delete", "$dir/$delete.bak")) { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!"; + } + } + else { + if (unlink "$dir/$delete") { + $success_msg = "Template '$delete' deleted"; + } + else { + $error_msg = "Unable to remove $dir/$delete: $!"; + } + } + } + +# Load any selected template file. + if ($selected_file and ! $tpl_text) { + if (-f "$dir/$selected_file") { + local (*FILE, $/); + open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + $local = 1; + $restore = 1 if -e "$self->{root}/$selected_dir/$selected_file"; + } + elsif (-f "$self->{root}/$selected_dir/$selected_file") { + local (*FILE, $/); + open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!"; + $tpl_text = ; + close FILE; + } + else { + $selected_file = ''; + } + } + +# Load a README if it exists. + my $readme; + if (-e "$dir/README") { + local (*FILE, $/); + open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)"; + $readme = ; + close FILE; + } + +# Set the textarea width and height. + my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 25; + my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 100; + my $file_select = $self->template_file_select; + my $dir_select = $self->template_dir_select; + $tpl_text = $self->{cgi}->html_escape($tpl_text); + my $stats = $selected_file ? $self->template_file_stats($selected_file) : {}; + + if ($self->{demo} and ($self->{cgi}->param('saveas') or $self->{cgi}->param("delete") or $self->{cgi}->param("restore"))) { + $error_msg = 'This feature has been disabled in the demo!'; + } + return { + tpl_name => $selected_file, + tpl_file => $selected_file, + local => $local, + restore => $restore, + tpl_text => \$tpl_text, + error_message => $error_msg, + success_message => $success_msg, + tpl_dir => $selected_dir, + readme => $readme, + editor_rows => $editor_rows, + editor_cols => $editor_cols, + dir_select => $dir_select, + file_select => $file_select, + %$stats + }; +} + +sub _skip_files { + my ($skip, $file) = @_; + return 1 if $skip->{$file} + or substr($file, 0, 1) eq '.' # skip dotfiles + or substr($file, -4) eq '.bak'; # skip .bak files + foreach my $f (keys %$skip) { + my $match = quotemeta $f; + $match =~ s/\\\*/.*/g; + $match =~ s/\\\?/./g; + return 1 if $file =~ /^$match$/; + } + return; +} + +sub template_file_select { +# ------------------------------------------------------------------ +# Returns a select list of templates in a given dir. +# + my $self = shift; + my $path = $self->{root}; + my %files; + my $sel_tpl_dir = $self->{select_dir}; + my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default'; + my $selected_file = $self->{cgi}->param('tpl_file') || $self->{default_file} || 'default'; + $selected_file = $self->{cgi}->param('tpl_name') if $self->{cgi}->param('saveas'); + my %skip; + if ($self->{skip_file}) { + for (@{$self->{skip_file}}) { + $skip{$_}++; + } + } + else { + $skip{README} = $skip{'language.txt'} = $skip{'globals.txt'} = 1; + } + +# Check the template directory + return if $selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..'; + + my $system_dir = $path . "/" . $selected_dir; + my $local_dir = $path . "/" . $selected_dir . '/local'; + foreach my $dir ($system_dir, $local_dir) { + opendir (TPL, $dir) or next; + while (defined(my $file = readdir TPL)) { + next unless -f "$dir/$file" and -r _; + next if _skip_files(\%skip, $file); + + $files{$file} = 1; + } + closedir TPL; + } + my $f_select_list = '{class}; + $d_select_list .= ">\n"; + foreach (sort @dirs) { + $d_select_list .= qq' | + } @$opts; +} + +# Returns the HTML escaped version of the provided string. +sub html_escape { + my $toescape = shift; + return "" unless defined $toescape; + $toescape =~ s/&/&/g; # This MUST happen first + $toescape =~ s/"/"/g; + $toescape =~ s//>/g; + return $toescape; +} + +# Returns a string such as "Saturday, January 1st, 2000, 00:00:00" for a integral time such as 946713600 +sub make_date_string ($) { + my $date = shift; + my @lt = localtime($date); + return "$WEEKDAY[$lt[6]], $MONTH[$lt[4]] $DAY[$lt[3]], ". + ($lt[5]+1900).", ".sprintf("%02d:%02d:%02d",@lt[2,1,0]); +} + +# ========================================= +# Actions +# ========================================= +# +# These subroutines (in the ACTIONS namespace) are called directly when a CGI +# option of: action=option is made. +# + +# The default frames page +sub ACTIONS::frames { + Links::admin_page( + "email_frames.html", + { + version => $Links::VERSION, + main => "admin.cgi?action=main", + contents => "admin.cgi?action=contents" + } + ); +} + +# A generic error page +sub ACTIONS::error { + Links::admin_page( + "email_error.html", + { + error => "@_" + } + ); +} + +# The main body page (to be displayed by ACTIONS::frames) +sub ACTIONS::main { + Links::admin_page( + "email_default.html", + { } + ); +} + +# The contents page (to be displayed by ACTIONS::frames) +sub ACTIONS::contents { + Links::admin_page( + "email_contents.html", + { } + ); +} + +# * -> "Load" (template) +sub ACTIONS::Load { + my $name = $IN->param('name'); + $ACTIONS::{$IN->param('previous')}->($name,get_template($name)) + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; +} + +# * -> "Save" (template) +sub ACTIONS::Save { + my $name = $IN->param('name'); + return $ACTIONS::{SaveAs}->() if $name eq $NEW_TEMPLATE or $name eq "LTPL$NEW_TEMPLATE" + or $name eq "CSTM$NEW_TEMPLATE"; + my $from = $IN->param('from'); + my $fromname = $IN->param('fromname'); + my $subject = $IN->param('subject'); + my $message = $IN->param('message'); + my $format = $IN->param('messageformat'); + save_template($name,$from,$fromname,$subject,$message,$format); + $ACTIONS::{$IN->param('previous')}->($name,(get_template($name))[0..4],$GT::SQL::error || "Template saved successfully") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; +} + +# * -> "Save as..." (template) +sub ACTIONS::SaveAs { + my $extra = $IN->param('extra'); + my $extraval = $IN->param($extra); + $IN->delete('name'); + my %substitutions = ( + notes => "@_", + from => defined $IN->param('from') ? scalar $IN->param('from') : "", + fromname => defined $IN->param('fromname') ? scalar $IN->param('fromname') : "", + subject => defined $IN->param('subject') ? scalar $IN->param('subject') : "", + message => defined $IN->param('message') ? scalar $IN->param('message') : "", + messageformat => defined $IN->param('messageformat') ? scalar $IN->param('messageformat') : "text", + previous => defined $IN->param('previous') ? scalar $IN->param('previous') : "", + hidden_fields => "" + ); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + chomp($substitutions{from}); + if ($substitutions{from} !~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + $ACTIONS::{$IN->param('previous')}->(undef,"",@substitutions{qw/fromname subject message messageformat/},"Invalid e-mail address entered. Correct it before saving the template") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; + return; + } + if (defined $extra) { + $substitutions{extra} = $extra; + $substitutions{extraval} = $extraval; + } + for (keys %substitutions) { + $substitutions{$_} =~ s/&/&/g; + $substitutions{$_} =~ s/"/"/g; + $substitutions{$_} =~ s/>/>/g; + $substitutions{$_} =~ s/param('previous') and substr($IN->param('previous'),0,8) eq 'selected') { + $substitutions{hidden_fields} = join "\n", map '', $IN->param; + } + Links::admin_page( + "email_newtemp_save_as.html", + \%substitutions + ); +} + +# * -> (Template) "Save as..." or "Save" with "(New template)" selected -> "Add Template" +sub ACTIONS::email_newtemp { + my $new_name = $IN->param('name'); + my $previous = $IN->param('previous'); + my $extra = $IN->param('extra'); + my $extraval = $IN->param($extra); + $new_name =~ s/^\s+//; + $new_name =~ s/\s+$//; + if ($previous eq 'all_links' or $previous eq 'selected_links_search') { + $new_name = "LTPL".$new_name; + } + elsif ($previous eq 'list_mail_list') { + $new_name = "CSTM".$new_name; + } + if ($new_name !~ /\S/ or $new_name eq 'NWSLTRTMPLT' or ($previous ne 'all_links' and + $previous ne 'selected_links_search' and substr($new_name,0,4) eq 'LTPL') or + ($previous ne 'list_mail_list' and substr($new_name,0,4) eq 'CSTM')) { + $ACTIONS::{SaveAs}->(qq|Bad input: Invalid template name ($new_name)!|); + } + else { + my $from = $IN->param('from'); + chomp($from); + add_template($new_name,($from =~ /^[\x20-\x7e]+\@$VALID_HOST$/ ? $from : ''), + $IN->param('fromname'),$IN->param('subject'),$IN->param('message'),$IN->param('messageformat')); + $IN->param($extra => $extraval) if defined $extra; + $ACTIONS::{$previous}->($new_name,(get_template($new_name))[0..4],"Template saved successfully"); + } +} + +# * -> "Delete" (template) +sub ACTIONS::Delete { + del_template($IN->param('name')) if $IN->param('name') and $IN->param('name') ne $NEW_TEMPLATE; + $ACTIONS::{$IN->param('previous')}->() if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; +} + +# "All Users","All Links","Newsletter" -> "Send" (mail) +sub ACTIONS::Send { + my $to = $IN->param('emailsto'); + return unless $to and ($to eq 'EVERYONE' or $to eq 'NEWSLETTER' or $to eq 'LINKOWNERS'); + + unless ($IN->param('from') and $IN->param('from') =~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + my %substitutions = ( + notes => "@_", + from => defined $IN->param('from') ? scalar $IN->param('from') : "", + fromname => defined $IN->param('fromname') ? scalar $IN->param('fromname') : "", + subject => defined $IN->param('subject') ? scalar $IN->param('subject') : "", + message => defined $IN->param('message') ? scalar $IN->param('message') : "", + messageformat => defined $IN->param('messageformat') ? scalar $IN->param('messageformat') : "text", + previous => defined $IN->param('previous') ? scalar $IN->param('previous') : "", + hidden_fields => "" + ); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + $ACTIONS::{$IN->param('previous')}->(undef,"",@substitutions{qw/fromname subject message messageformat/},"Invalid from e-mail address entered. You must correct it before sending the e-mails") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; + return; + } + + my $sth; + if ($to eq 'LINKOWNERS') { + my $cond = new GT::SQL::Condition; + my $email_cond = new GT::SQL::Condition; + $email_cond->add( $DB->prefix . 'Links.Contact_Email' => LIKE => '%_%'); + $email_cond->add( $DB->prefix . 'Users.Email' => LIKE => '%_%'); + $email_cond->boolean('OR'); + $cond->add($email_cond); + $cond->add($DB->prefix . 'Users.ReceiveMail' => 'Yes'); + $sth = $DB->table('Links','Users')->select($cond,[$DB->prefix . 'Links.Contact_Email',$DB->prefix . 'Users.Email',$DB->prefix . 'Links.ID']); + } + else { + my $cond = new GT::SQL::Condition; + $cond->add(Email => Like => '%_%'); + $cond->add(ReceiveMail => 'Yes'); + if ($to eq 'NEWSLETTER') { + my $catid = $IN->param('ID') || 0; + my $tree = $DB->table('Category')->tree; + my @ids = $catid == 0 ? (0) : (0, @{$tree->parent_ids(id => $catid)}, $catid); + $cond->add(CategoryID => IN => \@ids); + $sth = $DB->table('Users', 'NewsletterSubscription')->select($cond, ['Email']); + } + else { + $sth = $DB->table('Users')->select($cond, ['Email']); + } + } + my $mailingnum = $DB->table('MailingIndex')->insert( + extra => ($to eq 'LINKOWNERS' ? 'Links' : 'Users'), + mailfrom => $IN->param('from'), + name => $IN->param('fromname'), + subject => $IN->param('subject'), + message => $IN->param('message'), + messageformat => $IN->param('messageformat') + )->insert_id; + my $emailtable = $DB->table('EmailMailings'); + while (my $mail = $sth->fetchrow_arrayref()) { + $emailtable->insert( + Mailing => $mailingnum, + Email => ($to eq 'LINKOWNERS' ? ($mail->[0] || $mail->[1]) : $mail->[0]), + Sent => 0, + (@$mail > 1 ? (LinkID => $mail->[2]) : ()) + ); + } + $ACTIONS::{mailings}->('Mailing queued for sending. To send, select "Start mailing" below beside the mailing you just queued.'); +} + +# * -> "x recipients" +sub ACTIONS::list_addresses { + my $to = $IN->param('emailsto'); + return unless defined $to; + if ($to eq 'EVERYONE' or $to eq 'NEWSLETTER' or $to eq 'LINKOWNERS') { + my $cond = new GT::SQL::Condition; + if ($to eq 'LINKOWNERS') { + my $email_cond = new GT::SQL::Condition; + $email_cond->add($DB->prefix . "Links.Contact_Email" => LIKE => '%_%'); + $email_cond->add($DB->prefix . "Users.Email" => LIKE => '%_%'); + $email_cond->boolean("OR"); + $cond->add($email_cond); + $cond->add($DB->prefix . "Users.ReceiveMail" => 'Yes'); + } + else { + $cond->add(Email => LIKE => '%_%'); + $cond->add(ReceiveMail => 'Yes'); + if ($to eq 'NEWSLETTER') { + my $catid = $IN->param('ID') || 0; + my $tree = $DB->table('Category')->tree; + my @ids = $catid == 0 ? (0) : (0, @{$tree->parent_ids(id => $catid)}, $catid); + + $cond->add(CategoryID => IN => \@ids); + } + } + my @t = $to eq 'LINKOWNERS' ? ('Links','Users') : $to eq 'NEWSLETTER' ? ('Users', 'NewsletterSubscription') : ('Users'); + Links::admin_page( + "email_list.html", + { + addresses => join "
        \n", + map { $_->[0] =~ /\S/ ? ($_->[0]) : ($to eq 'LINKOWNERS' ? $_->[1] : ()) } + @{$DB->table(@t)->select($cond,[$to eq 'LINKOWNERS' ? ($DB->prefix . 'Links.Contact_Email', $DB->prefix . 'Users.Email') : $DB->prefix . 'Users.Email'])->fetchall_arrayref} + } + ); + } + elsif ($to eq 'CUSTOMLIST') { + my $id = $IN->param('ID'); + Links::admin_page( + "email_list.html", + { + addresses => join "
        \n", map $_->[0], + @{$DB->table('MailingList')->select({ ID => $id },['Email'])->fetchall_arrayref} + } + ); + } + elsif ($to eq 'SELECTEDUSERS' or $to eq 'SELECTEDLINKS') { + my $tablename = $to eq 'SELECTEDUSERS' ? 'Users' : 'Links'; + my $table = $DB->table($tablename); + $IN->delete("action"); + my $sth = $table->query_sth($IN); + my @emails; + if ($tablename eq 'Links') { + my $Users = $DB->table('Users'); + while ($_ = $sth->fetchrow_hashref) { + my ($Email, $ReceiveMail) = $Users->select({ Username => $_->{'LinkOwner'} }, ['Email','ReceiveMail'])->fetchrow_array; + push @emails, $_->{Contact_Email} || $Email if $ReceiveMail and $ReceiveMail eq 'Yes'; + } + } + else { + while ($_ = $sth->fetchrow_hashref) { + push @emails, $_->{Email}; + } + } + Links::admin_page( + "email_list.html", + { + addresses => join("
        \n", @emails) + } + ); + } + else { + Links::admin_page( + "email_list.html", + { + addresses => join "
        \n", map $_->[0], + @{$DB->table('EmailMailings')->select({ Mailing => $to },['Email'])->fetchall_arrayref()} + } + ); + } +} + +# "All Users" +sub ACTIONS::email_everyone { + my ($selected,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + my $cond = new GT::SQL::Condition; + $cond->add(Email => Like => '%_%'); + $cond->add(ReceiveMail => '=' => 'Yes'); + Links::admin_page( + "email_everyone.html", + { + number => $DB->table('Users')->count($cond), + templates => make_opts([$NEW_TEMPLATE,template_names()],$selected), + from => html_escape($from), + fromname => html_escape($fromname), + subject => html_escape($subject), + message => html_escape($message), + messageformat => make_opts([qw/text html/],$format), + error => $error || "" + } + ); +} + +# "All Links" +sub ACTIONS::all_links { + my ($selected,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + my $cond = new GT::SQL::Condition; + my $email_cond = new GT::SQL::Condition; + $email_cond->add($DB->prefix . 'Links.Contact_Email' => 'LIKE' => '%_%'); + $email_cond->add($DB->prefix . 'Users.Email' => LIKE => '%_%'); + $email_cond->bool('OR'); + $cond->add($email_cond); + $cond->add($DB->prefix . "Users.ReceiveMail" => 'Yes'); + Links::admin_page( + "email_link_owners.html", + { + number => ($DB->table('Links','Users')->count($cond)), + templates => make_opts([$NEW_TEMPLATE,template_names('LTPL')],$selected,"LTPL"), + from => html_escape($from), + fromname => html_escape($fromname), + subject => html_escape($subject), + message => html_escape($message), + messageformat => make_opts([qw/text html/],$format), + error => $error || "" + } + ); +} + +# "Selected Users" +sub ACTIONS::selected_users { + my $html = $DB->html($DB->table('Users'), $IN); + $html->{code}{ReceiveMail} = sub {qq{ReceiveMailYes\n \n}}; + Links::admin_page( + "email_selected_users.html", + { + message => "@_", + form => $html->form({ mode => 'search_form', search_opts => 1 }), + } + ); +} + +# "Selected Users" -> "Search" +sub ACTIONS::selected_users_search { + my ($selected,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + $IN->delete('action'); + $IN->delete('name'); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + my $sth = $DB->table('Users')->query_sth($IN); + my $list_addrs_url = $IN->url; + $list_addrs_url .= "&action=list_addresses&emailsto=SELECTEDUSERS"; + my $count = $sth->rows; + return $ACTIONS::{selected_users}->("No matches found") unless $count; + my $hidden_fields = ""; + for my $key ($IN->param) { + my @v = $IN->param($key); + for (@v) { + $hidden_fields .= qq{\n}; + } + } + Links::admin_page( + "email_selected_users_mail.html", + { + number => $count, + address_list_url => $list_addrs_url, + hidden_fields => $hidden_fields, + templates => make_opts([$NEW_TEMPLATE,template_names()],$selected), + from => $from, + fromname => $fromname, + subject => $subject, + message => $message, + messageformat => make_opts([qw/text html/],$format), + error => $error || "" + } + ); +} + +# "Selected Users" -> "Search" -> "Send" +sub ACTIONS::selected_users_send { + my $sth = $DB->table('Users')->query_sth($IN); + my $emailtable = $DB->table('EmailMailings'); + + unless ($IN->param('from') and $IN->param('from') =~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + my %substitutions = ( + notes => "@_", + from => defined $IN->param('from') ? scalar $IN->param('from') : "", + fromname => defined $IN->param('fromname') ? scalar $IN->param('fromname') : "", + subject => defined $IN->param('subject') ? scalar $IN->param('subject') : "", + message => defined $IN->param('message') ? scalar $IN->param('message') : "", + messageformat => defined $IN->param('messageformat') ? scalar $IN->param('messageformat') : "text", + previous => defined $IN->param('previous') ? scalar $IN->param('previous') : "", + hidden_fields => "" + ); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + $ACTIONS::{$IN->param('previous')}->(undef,"",@substitutions{qw/fromname subject message messageformat/},"Invalid from e-mail address entered. You must correct it before sending the e-mails") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; + return; + } + + my $mailingnum = $DB->table('MailingIndex')->insert( + extra => 'Users', + mailfrom => $IN->param('from'), + name => $IN->param('fromname'), + subject => $IN->param('subject'), + message => $IN->param('message'), + messageformat => $IN->param('messageformat') + )->insert_id; + while ($_ = $sth->fetchrow_hashref) { + $emailtable->insert( + Mailing => $mailingnum, + Email => $_->{Email} + ); + } + $ACTIONS::{mailings}->('Mailing queued for sending. To send, select "Start mailing" below beside the mailing you just queued.'); +} + +# "Selected Links" +sub ACTIONS::selected_links { + Links::admin_page( + "email_selected_links.html", + { + message => "@_", + form => $DB->html($DB->table('Links'), $Links::IN)->form({ mode => 'search_form', search_opts => 1 }), + } + ); +} + +# "Selected Links" -> "Search" +sub ACTIONS::selected_links_search { + my ($selected,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + $IN->delete('action'); + $IN->delete('name'); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + my $sth = $DB->table('Links')->query_sth($IN); + my $Users = $DB->table('Users'); + my $count; + while ($_ = $sth->fetchrow_hashref) { + ++$count if $Users->select({ Username => $_->{LinkOwner} },['ReceiveMail'])->fetchrow_array eq 'Yes'; + } + return $ACTIONS::{selected_links}->("No matches found") unless $count; + my $list_addrs_url = $IN->url; + $list_addrs_url .= "&action=list_addresses&emailsto=SELECTEDLINKS"; + my $hidden_fields = ""; + for my $key ($IN->param) { + my @v = $IN->param($key); + for (@v) { + $hidden_fields .= qq{\n}; + } + } + Links::admin_page( + "email_selected_links_mail.html", + { + number => $count, + address_list_url => $list_addrs_url, + hidden_fields => $hidden_fields, + templates => make_opts([$NEW_TEMPLATE,template_names('LTPL')],$selected,"LTPL"), + from => $from, + fromname => $fromname, + subject => $subject, + message => $message, + messageformat => make_opts([qw/text html/],$format), + error => $error || "" + } + ); +} + +# "Selected Links" -> "Search" -> "Send" +sub ACTIONS::selected_links_send { + my $sth = $DB->table('Links')->query_sth($IN); + + unless ($IN->param('from') and $IN->param('from') =~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + my %substitutions = ( + notes => "@_", + from => defined $IN->param('from') ? scalar $IN->param('from') : "", + fromname => defined $IN->param('fromname') ? scalar $IN->param('fromname') : "", + subject => defined $IN->param('subject') ? scalar $IN->param('subject') : "", + message => defined $IN->param('message') ? scalar $IN->param('message') : "", + messageformat => defined $IN->param('messageformat') ? scalar $IN->param('messageformat') : "text", + previous => defined $IN->param('previous') ? scalar $IN->param('previous') : "", + hidden_fields => "" + ); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + $ACTIONS::{$IN->param('previous')}->(undef,"",@substitutions{qw/fromname subject message messageformat/},"Invalid from e-mail address entered. You must correct it before sending the e-mails") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; + return; + } + + my $emailtable = $DB->table('EmailMailings'); + my $mailingnum = $DB->table('MailingIndex')->insert( + extra => 'Links', + mailfrom => $IN->param('from'), + name => $IN->param('fromname'), + subject => $IN->param('subject'), + message => $IN->param('message'), + messageformat => $IN->param('messageformat') + )->insert_id; + my $Users = $DB->table('Users'); + while ($_ = $sth->fetchrow_hashref) { + my $user = $Users->select({ Username => $_->{LinkOwner} },['ReceiveMail','Email'])->fetchrow_hashref; + if ($user->{ReceiveMail} eq 'Yes') { + $emailtable->insert( + Mailing => $mailingnum, + Email => $_->{Contact_Email} || $user->{Email}, + Sent => 0, + LinkID => $_->{ID} + ); + } + } + $ACTIONS::{mailings}->('Mailing queued for sending. To send, select "Start mailing" below beside the mailing you just queued.'); +} + +# "Newsletter" +sub ACTIONS::email_newsletter { + my ($from,$fromname,$subject,$message,$format,$template,$error); + if (@_) { + (undef,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + ($template) = (get_template('NWSLTRTMPLT'))[5]; + } + else { + ($from,$fromname,$subject,$message,$format,$template) = get_template('NWSLTRTMPLT'); + } + my $news = ""; +# my ($from,$fromname,$subject,$message,$format,$template) = get_template('NWSLTRTMPLT'); + unless ($error) { + $message .= "\n<%news%>" unless defined $message and $message =~ /<%news%>/; + $template ||= DEFAULT_NEWSLETTER_TEMPLATE; + + my $catid = $IN->param('ID') || 0; + my $sth; + if ($catid) { + my $tree = $DB->table('Category')->tree; + my @ids = ($catid, @{$tree->child_ids(id => $catid)}); + $sth = $DB->table('Links', 'CatLinks')->select({ isNew => 'Yes', CategoryID => \@ids }, VIEWABLE); + } + else { + $sth = $DB->table('Links')->select({ isNew => 'Yes' }, VIEWABLE); + } + while (my $row = $sth->fetchrow_hashref) { + $news .= GT::Template->parse('New item template', + { map { ($_ => $$row{$_}) } keys %$row }, + { string => $template, compress => 0 } + ) . "\n"; + } + $message =~ s/<%news%>/$news/g; + } + $error = "Template saved successfully" if $IN->param('newslettermessage'); + + my $catid = $IN->param('ID') || 0; + my $tree = $DB->table('Category')->tree; + my @ids = $catid == 0 ? (0) : (0, @{$tree->parent_ids(id => $catid)}, $catid); + + my $cond = new GT::SQL::Condition; + $cond->add(Email => LIKE => '%_%'); + $cond->add(ReceiveMail => '=' => 'Yes'); + $cond->add(CategoryID => IN => \@ids); + Links::admin_page( + "email_newsletter.html", + { + number => ($DB->table('Users', 'NewsletterSubscription')->count($cond)), + from => html_escape($from), + fromname => html_escape($fromname), + subject => html_escape($subject), + message => html_escape($message), + messageformat => make_opts([qw/text html/],$format), + error => $error || "" + } + ); +} + +# "Newsletter" -> "Edit newsletter template" +sub ACTIONS::email_newsletter_edit_template { + my ($from,$fromname,$subject,$message,$format,$template,$bad_email); + if (@_) { + ($from,$fromname,$subject,$message,$format,$template) = @_; + $bad_email = 1; + } + else { + ($from,$fromname,$subject,$message,$format,$template) = get_template('NWSLTRTMPLT'); + } + Links::admin_page( + "email_newsletter_edit_template.html", + { + from => html_escape($from), + fromname => html_escape($fromname), + subject => html_escape($subject), + message => html_escape($message), + messageformat => make_opts([qw/text html/],$format), + template => html_escape($template || DEFAULT_NEWSLETTER_TEMPLATE), + bad_email => $bad_email, + } + ); +} + +# "Newsletter" -> "Edit newsletter template" -> "Save Newsletter Template" +sub ACTIONS::email_newsletter_save_template { + unless ($IN->param('fromname') and $IN->param('subject') and $IN->param('message') and $IN->param('from') and $IN->param('from') =~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + $ACTIONS::{email_newsletter_edit_template}->(map $IN->param($_), qw/from fromname subject message messageformat template/); + return; + } + save_template( + 'NWSLTRTMPLT', $IN->param('from'), $IN->param('fromname'), $IN->param('subject'), + $IN->param('message'), $IN->param('messageformat'), $IN->param('template') + ); + $ACTIONS::{email_newsletter}->(); +} + +# Custom List "List" +sub ACTIONS::list_list { + my @list = @{$DB->table('MailingListIndex')->select({ },[qw/ID Name DateCreated DateModified/])->fetchall_arrayref}; + my $output = "
          \n"; + for (@list) { + my $count = $DB->table('MailingList')->count({ ID => $_->[0] }); + my $created = make_date_string($_->[2]); + my $modified = make_date_string($_->[3]); + $output .= qq+
        • $_->[1] - $count e-mail address@{[$count == 1 ? "" : "es"]}
        • \n+; + } + $output .= "
        \n"; + $output = "No lists have been created" if $output eq "
          \n
        \n"; + Links::admin_page( + "email_list_of_lists.html", + { + lists => $output + } + ); +} + +# Custom List "List" -> click one +sub ACTIONS::list_addresslist { + my $id = $IN->param('ID'); + my %index = %{$DB->table('MailingListIndex')->select({ ID => $id })->fetchrow_hashref}; + my @addresses = map html_escape($_->[0]), @{$DB->table('MailingList')->select({ ID => $id }, ['Email'])->fetchall_arrayref}; + local $" = "
        \n"; + Links::admin_page( + "email_list_list.html", + { + DateCreated => make_date_string($index{DateCreated}), + DateModified => make_date_string($index{DateModified}), + Name => $index{Name}, + ID => $index{ID}, + addresses => "@addresses
        \n" + } + ); +} + +# Custom List "Add" +sub ACTIONS::list_add { + Links::admin_page( + "email_list_add.html", + { + message => "@_", + addresses => scalar $IN->param('addresses') + } + ); +} + +# Custom List "Add" -> "Add List" +sub ACTIONS::add_new_list { + my $name = $IN->param('name'); + $name =~ s/^\s+//; + $name =~ s/\s+$//; + unless ($name =~ /\S/) { + $ACTIONS::{list_add}->("Invalid name entered"); + return; + } + elsif ($DB->table('MailingListIndex')->count({ Name => $name })) { + $ACTIONS::{list_add}->("List `$name' already exists"); + return; + } + my $now = time; + my $insert_id = $DB->table('MailingListIndex')->insert({ Name => $name, DateCreated => $now, DateModified => $now })->insert_id; + my $output; + if (defined $insert_id) { + $output = "Added mailing list ".html_escape($name).".

        \n"; + my %addr; + for (grep !$addr{$_}++, split ' ',$IN->param('addresses')) { + chomp; + if (/^[\x21-\x7e]+\@$VALID_HOST$/) { + $output .= "Added ".html_escape($_)." to mailing list.
        \n"; + $DB->table('MailingList')->insert({ ID => $insert_id, Email => $_ }); + } + else { + $output .= "".html_escape($_)." ($_) is not a valid email address.
        \n"; + } + } + } + else { + $output = "An error occured while attempting to add mailing list ".html_escape($name).": $GT::SQL::error."; + } + Links::admin_page( + "email_list_added.html", + { + status => $output + } + ); +} + +# Custom List "Modify" +sub ACTIONS::list_modify { + my @list = @{$DB->table('MailingListIndex')->select({ }, ['ID','Name'])->fetchall_arrayref}; + return ACTIONS::list_add("No mailing lists exist! You must add a list before any can be modified") unless @list; + my $output = "\n"; + Links::admin_page( + "email_list_modify.html", + { + list => $output + } + ); +} + +# Custom List "Modify" -> "Modify" +sub ACTIONS::list_modify_list { + my $id = $IN->param('ID'); + my $name = $DB->table('MailingListIndex')->select({ ID => $id },['Name'])->fetchrow_arrayref->[0]; + my @addresses = map $$_[0], @{$DB->table('MailingList')->select({ ID => $id },['Email'])->fetchall_arrayref}; + local $" = "\n"; + Links::admin_page( + "email_list_modify_list.html", + { + Name => $name, + ID => $id, + addresses => "@addresses" + } + ); +} + +# Custom List "Modify" -> "Modify" -> "Modify List" +sub ACTIONS::list_modify_existing_list { + my $id = $IN->param('ID'); + my $MailingList = $DB->table('MailingList'); + $MailingList->delete({ ID => $id }); + my $now = time; + my $MailingListIndex = $DB->table('MailingListIndex'); + $MailingListIndex->update({ DateModified => $now }, { ID => $id }); + my $name = $MailingListIndex->select({ ID => $id },['Name'])->fetchrow_arrayref->[0]; + my $output = "Modifying ".html_escape($name).".

        \n"; + my %addr; + for (grep !$addr{$_}++, split ' ',$IN->param('addresses')) { + chomp; + if (/^[\x21-\x7e]+\@$VALID_HOST$/) { + $output .= "Added ".html_escape($_)." to mailing list.
        \n"; + $MailingList->insert({ ID => $id, Email => $_ }); + } + else { + $output .= "".html_escape($_)." is not a valid email address.
        \n"; + } + } + Links::admin_page( + "email_list_moded.html", + { + status => $output + } + ); +} + +# Custom List "Delete" +sub ACTIONS::list_delete { + my @list = @{$DB->table('MailingListIndex')->select({ }, ['ID','Name'])->fetchall_arrayref}; + return ACTIONS::list_add("No mailing lists exist! You must add a list before any can be deleted") unless @list; + my $output = "\n"; + Links::admin_page( + "email_list_delete.html", + { + list => $output + } + ); +} + +# Custom List "Delete" -> "Delete List" +sub ACTIONS::list_delete_list { + my $id = $IN->param('ID'); + my $MailingListIndex = $DB->table('MailingListIndex'); + my $name = $MailingListIndex->select({ ID => $id },['Name'])->fetchrow_arrayref->[0]; + $MailingListIndex->delete({ ID => $id }); + $DB->table('MailingList')->delete({ ID => $id }); + Links::admin_page( + "email_list_delete_list.html", + { + Name => $name + } + ); +} + +# Custom List "Mail" +sub ACTIONS::list_mail { + my @list = @{$DB->table('MailingListIndex')->select({ }, ['ID','Name'])->fetchall_arrayref}; + return ACTIONS::list_add("No mailing lists exist! You must add a list before any mail can be sent to a list") unless @list; + my $output = "\n"; + Links::admin_page( + "email_list_mail.html", + { + list => $output + } + ); +} + +# Custom List "Mail" -> "Next" +sub ACTIONS::list_mail_list { + my ($selected,$from,$fromname,$subject,$message,$format,$error) = splice @_,0,7; + my $id = $IN->param('ID'); + Links::admin_page( + "email_list_mail_list.html", + { + number => $DB->table('MailingList')->count({ ID => $id }), + templates => make_opts([$NEW_TEMPLATE,template_names('CSTM')],$selected,'CSTM'), + from => html_escape($from), + fromname => html_escape($fromname), + subject => html_escape($subject), + message => html_escape($message), + messageformat => make_opts([qw/text html/],$format), + ID => $id, + error => $error || "" + } + ); +} + +# Custom List "Mail" -> "Next" -> "Send Emails" +sub ACTIONS::list_mail_Send { + my $id = $IN->param('ID'); + + unless ($IN->param('from') and $IN->param('from') =~ /^[\x21-\x7e]+\@$VALID_HOST\Z/) { + my %substitutions = ( + notes => "@_", + from => defined $IN->param('from') ? scalar $IN->param('from') : "", + fromname => defined $IN->param('fromname') ? scalar $IN->param('fromname') : "", + subject => defined $IN->param('subject') ? scalar $IN->param('subject') : "", + message => defined $IN->param('message') ? scalar $IN->param('message') : "", + messageformat => defined $IN->param('messageformat') ? scalar $IN->param('messageformat') : "text", + previous => defined $IN->param('previous') ? scalar $IN->param('previous') : "", + hidden_fields => "" + ); + $IN->delete('from'); + $IN->delete('fromname'); + $IN->delete('subject'); + $IN->delete('message'); + $IN->delete('messageformat'); + $IN->delete('action'); + $ACTIONS::{$IN->param('previous')}->(undef,"",@substitutions{qw/fromname subject message messageformat/},"Invalid from e-mail address entered. You must correct it before sending the e-mails") + if exists $ACTIONS::{$IN->param('previous')} and ref *{$ACTIONS::{$IN->param('previous')}}{CODE} eq 'CODE'; + return; + } + + my $fromname = $IN->param('fromname'); + my $from = $IN->param('from'); + my $subject = $IN->param('subject'); + my $message = $IN->param('message'); + my $format = $IN->param('messageformat'); + $from or return; + my $sth = $DB->table('MailingList')->select({ ID => $id },['Email']); + my $mailingnum = $DB->table('MailingIndex')->insert( + extra => 'none', + mailfrom => $from, + name => $fromname, + subject => $subject, + message => $message, + messageformat => $format + )->insert_id; + my $emailtable = $DB->table('EmailMailings'); + while (my $mail = $sth->fetchrow_arrayref()) { + $emailtable->insert( + Mailing => $mailingnum, + Email => $mail->[0] + ); + } + $ACTIONS::{mailings}->('Mailing queued for sending. To send, select "Start mailing" below beside the mailing you just queued.'); +} + +# "View mailings" (Also shown immediately after queuing a message) +sub ACTIONS::mailings { + my $error = shift; + my @mailings; + my $sth = $DB->table('MailingIndex')->select(); + my $row; + push @mailings, $row while $row = $sth->fetchrow_hashref(); + my $mailstr; + for (@mailings) { + my $completed_condition = new GT::SQL::Condition; + $completed_condition->add('Mailing' => '=' => $$_{Mailing}); + $completed_condition->add('done' => 'IS NOT' => \"NULL"); + my $completed = $DB->table('MailingIndex')->count($completed_condition); + my ($total,$done); + unless ($completed) { + $total = $DB->table('EmailMailings')->count({ Mailing => $$_{Mailing} }); + $done = $DB->table('EmailMailings')->count({ Sent => 1, Mailing => $$_{Mailing} }); + } + $mailstr .= < + ID: $$_{Mailing} + | + Subject: @{[html_escape($$_{subject})]} + | + @{[$completed ? "This mailing has been completed." : "$done/$total sent."]} + | + Details + | + @{[$completed ? "" : qq~@{[$done ? "Continue" : "Start"]} mailing + |~]} + @{[$completed ? "Delete" : "Cancel"]} mailing + + +MAILING + } + $mailstr ||= "There are no mailings to display."; + Links::admin_page( + "email_mailings.html", + { + mailings => $mailstr, + error => $error || "" + } + ); +} + +# "View Mailings" -> "Details" +sub ACTIONS::show_mailing_detail { + my $mailing = $IN->param('mailing'); + my %info = %{$DB->table('MailingIndex')->select({ Mailing => $mailing })->fetchrow_hashref()}; + my $count = $DB->table('EmailMailings')->count({ Mailing => $mailing }); + ($info{message} = html_escape($info{message})) =~ s/(\r?\n)/
        $1/g; + my $finished; + $finished = make_date_string($info{done}) if defined $info{done}; + Links::admin_page( + "email_mailing_detail.html", + { + map({ ($_ => html_escape($info{$_})) } qw{ mailfrom name subject messageformat }), + message => $info{message}, + id => $mailing, + count => $count, + finished => $finished + } + ); +} + +# "View Mailings" -> "Cancel mailing","Delete mailing" +sub ACTIONS::cancel_mailing { + my $mailing = $IN->param('mailing'); + my %info = %{$DB->table('MailingIndex')->select({ Mailing => $mailing })->fetchrow_hashref()}; + my $count = $DB->table('EmailMailings')->count({ Mailing => $mailing }); + ($info{message} = html_escape($info{message})) =~ s/\r?\n/
        \n/g; + my $finished; + $finished = make_date_string($info{done}) if defined $info{done}; + Links::admin_page( + "email_confirm_cancel_mailing.html", + { + Verbtion => defined $info{done} ? "Deletion" : "Cancellation", + verbed => defined $info{done} ? "deleted" : "cancelled", + map({ ($_ => html_escape($info{$_})) } qw{ mailfrom name subject }), + message => $info{message}, + id => $mailing, + count => $count, + finished => $finished + } + ); +} + +# "View Mailings" -> "Cancel mailing","Delete mailing" -> "Confirm Mailing Deletion","Confirm Mailing Cancellation" +sub ACTIONS::confirmed_cancel_mailing { + my $mailing = $IN->param('mailing'); + $DB->table('MailingIndex')->delete({ Mailing => $mailing }); + $DB->table('EmailMailings')->delete({ Mailing => $mailing }); + $ACTIONS::{mailings}->("Selected mailing has been ".$IN->param('verbed')); +} + +# "View Mailings" -> "Delete all completed mailings" +sub ACTIONS::delete_finished_mailings { + my $cond = new GT::SQL::Condition; + $cond->add('done' => 'IS NOT' => \'NULL'); + Links::admin_page( + "email_confirm_delete_finished_mailings.html", + { + count => $DB->table('MailingIndex')->count($cond) + } + ); +} + +# "View Mailings" -> "Delete all completed mailings" -> "Confirm Delete All Finished Mailings" +sub ACTIONS::confirmed_delete_finished_mailings { + my $cond = new GT::SQL::Condition; + $cond->add('done' => 'IS NOT' => \'NULL'); + my @mailing = map $_->[0], @{$DB->table('MailingIndex')->select($cond,['Mailing'])->fetchall_arrayref}; + for (@mailing) { + $DB->table('EmailMailings')->delete({ Mailing => $_ }); + $DB->table('MailingIndex')->delete({ Mailing => $_ }); + } + $ACTIONS::{mailings}->("All finished mailings have been deleted"); +} + +# "View Mailings" -> "Cancel/Delete all mailings" +sub ACTIONS::delete_all_mailings { + Links::admin_page( + "email_confirm_delete_all_mailings.html", + { + count => $DB->table('MailingIndex')->count() + } + ); +} + +# "View Mailings" -> "Cancel/Delete all mailings" -> "Confirm Delete All Mailings" +sub ACTIONS::confirmed_delete_all_mailings { + $DB->table('EmailMailings')->delete_all; + $DB->table('MailingIndex')->delete_all; + $ACTIONS::{mailings}->("All mailings have been cancelled and/or deleted"); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Newsletter.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Newsletter.pm new file mode 100644 index 0000000..21d00f5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Newsletter.pm @@ -0,0 +1,622 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Newsletter.pm,v 1.15 2007/09/06 01:43:45 brewt 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. +# ================================================================== + +# Notes about the Newsletter code: +# ================================ +# Example category structure: +# a +# b +# c +# d +# If a user is subscribed to a category (eg. category a), then they will +# be automatically subscribed to all the subcategories of that category +# (ie. b, c, d). If the user is already subscribed to a subcategory +# (eg. b), then that subscription will be removed when they subscribe to +# a parent category (ie. a). This keeps listing subscribed categories +# simple. +# +# Remember that the root category (0) is a special category and needs to be +# handled appropriately. It is not a real category as it does not exist in +# the Category table. + +package Links::Newsletter; + +use strict; +use Links qw/:objects/; +use Links::SiteHTML; +use GT::Dumper; + +sub handle { +# --------------------------------------------------- +# Determine what to do. +# + my $res; + my $action = lc $IN->param('action'); + + require Links::Build; + my $mtl = Links::Build::build('title', Links::language('LINKS_NEWSLETTER'), "$CFG->{db_cgi_url}/subscribe.cgi"); + +# Custom lists + if ($IN->param('list')) { + my $email = $IN->param('email'); + if ($email and $action eq 'subscribe') { + $res = $PLG->dispatch('custom_list_subscribe', \&custom_list_subscribe); + } + elsif ($email and $action eq 'unsubscribe') { + $res = $PLG->dispatch('custom_list_unsubscribe', \&custom_list_unsubscribe); + } + else { + $res = { error => Links::language('SUBSCRIBE_ERROR') }; + } + $res->{main_title_loop} ||= $mtl; + print $IN->header(); + print Links::SiteHTML::display('newsletter', $res); + } + +# With the old Newsletter code, anyone could sign up to it. This is bad since +# no e-mail validation is performed. The new code will only allow signed up +# users to sign up. + unless ($USER) { + print $IN->redirect(Links::redirect_login_url('subscribe')); + return; + } + + my $page; + if ($CFG->{newsletter_global_subscribe}) { + $page = 'newsletter_global'; + if ($action eq 'subscribe') { + $res = $PLG->dispatch('newsletter_global_sub', \&global_subscribe); + } + elsif ($action eq 'unsubscribe') { + $res = $PLG->dispatch('newsletter_global_unsub', \&global_unsubscribe); + } + } + elsif ($action eq 'list') { + $page = 'newsletter_list'; + } + elsif ($action eq 'unsubscribe') { + $res = $PLG->dispatch('newsletter_unsubscribe', \&unsubscribe); + $page = $IN->param('page') || 'newsletter'; + } + elsif ($action eq 'subscribe') { + $res = $PLG->dispatch('newsletter_subscribe', \&subscribe); + $page = 'newsletter'; + } + elsif ($action eq 'update') { + $res = $PLG->dispatch('newsletter_update', \&update_subscription); + $page = 'newsletter_browse'; + } + else { + $page = 'newsletter_browse'; + } + $res->{main_title_loop} ||= $mtl; + + print $IN->header(); + print Links::SiteHTML::display($page, $res); +} + +sub custom_list_subscribe { +# --------------------------------------------------- +# Subscribe to a custom list +# + my $list = $IN->param('list'); + my $email = $IN->param('email'); + my $mli = $DB->table('MailingListIndex'); + my $ml = $DB->table('MailingList'); + unless ($mli->count({ Name => $list })) { + return { error => Links::language('SUBSCRIBE_INVALIDLIST', $list) }; + } + + my $id = $mli->select('ID', { Name => $list })->fetchrow; + + if ($ml->count({ Email => $email, ID => $id })) { + return { error => Links::language('SUBSCRIBE_ALREADYSUB') }; + } + $ml->insert({ Email => $email, ID => $id }); + return { message => Links::language('SUBSCRIBE_SUCCESS') }; +} + +sub custom_list_unsubscribe { +# --------------------------------------------------- +# Unsubscribe from a custom list +# + my $list = $IN->param('list'); + my $email = $IN->param('email'); + my $mli = $DB->table('MailingListIndex'); + my $ml = $DB->table('MailingList'); + unless ($mli->count({ Name => $list })) { + return { error => Links::language('SUBSCRIBE_INVALIDLIST', $list) }; + } + + my $id = $mli->select('ID', { Name => $list })->fetchrow; + + unless ($ml->count({ Email => $email, ID => $id })) { + return { error => Links::language('SUBSCRIBE_NOTSUB') }; + } + $ml->delete({ Email => $email, ID => $id }); + return { message => Links::language('SUBSCRIBE_UNSUBSUCCESS') }; +} + +sub global_subscribe { +# --------------------------------------------------- +# Global subscribe to the newsletter. If the admin option is enabled, then this +# will behave like the newsletter did in 2.x, where there is only one global +# newsletter. The only difference is that only registered users can subscribe. +# + my $ns = $DB->table('NewsletterSubscription'); + + if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) { + return { error => Links::language('NEWSLETTERERR_ALREADYSUB') }; + } + _subscribe(0); + return { message => Links::language('NEWSLETTER_SUBSCRIBED') }; +} + +sub global_unsubscribe { +# --------------------------------------------------- +# Unsubscribe from the newsletter. +# + my $ns = $DB->table('NewsletterSubscription'); + + if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) { + _unsubscribe(0); + return { message => Links::language('NEWSLETTER_UNSUBSCRIBED') }; + } + return { error => Links::language('NEWSLETTERERR_NOTSUB') }; +} + +sub global_subscribe_info { +# --------------------------------------------------- +# Returns information about the user's newsletter subscription. +# + return { subscribed => $DB->table('NewsletterSubscription')->count({ UserID => $USER->{Username}, CategoryID => 0 }) }; +} + +sub list_subscribed { +# --------------------------------------------------- +# Returns a list of categories they are subscribed to. +# + my $ns = $DB->table('NewsletterSubscription'); + my $nsc = $DB->table('NewsletterSubscription', 'Category'); + + if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) { + return { subscribed => [_root()] }; + } + + $nsc->select_options("ORDER BY Full_Name"); + my $list = $nsc->select({ UserID => $USER->{Username} })->fetchall_hashref; + return { subscribed => $list }; +} + +sub unsubscribe { +# --------------------------------------------------- +# Unsubscribe from one or more categories. +# + my @unsub = $IN->param('ID'); + @unsub = @_ unless @unsub; + + return { error => Links::language('NEWSLETTERERR_NOCATSUB') } unless @unsub; + + _unsubscribe(@unsub); + + return { message => Links::language('NEWSLETTER_CATUNSUB') }; +} + +sub subscribe { +# --------------------------------------------------- +# Subscribe to one or more categories. +# + my @sub = $IN->param('ID'); + @sub = @_ unless @sub; + + return { error => Links::language('NEWSLETTER_NOCATUNSUB') } unless @sub; + + _subscribe(@sub); + + return { message => Links::language('NEWSLETTER_CATSUB') }; +} + +sub update_subscription { +# --------------------------------------------------- +# Update a User's category subscriptions from their browse selection. +# + +# These should be the original subscribe states of the categories. S are the +# categories which they wish to be subscribed to. + my @presub = $IN->param('subscribed'); + my @preunsub = $IN->param('unsubscribed'); + my (@sub, @unsub); + + for (@presub) { + next if $_ =~ /\D/; + push @unsub, $_ unless defined $IN->param("S$_"); + } + _unsubscribe(@unsub); + + for (@preunsub) { + next if $_ =~ /\D/; + push @sub, $_ if defined $IN->param("S$_"); + } + _subscribe(@sub); + + return { message => Links::language('NEWSLETTER_CATUPDATED') }; +} + +sub browse { +# --------------------------------------------------- +# Browse the categories. +# + my $root = $IN->param('root') || 0; + my $cat = $DB->table('Category'); + my $ns = $DB->table('NewsletterSubscription'); + if ($root != 0 and not $cat->count({ ID => $root })) { + $root = 0; + } + + my $root_cat; + if ($root == 0) { + $root_cat = _root(); + $root_cat->{CatDepth} = -1; + } + else { + $root_cat = $cat->select({ ID => $root })->fetchrow_hashref or return { error => $GT::SQL::error }; + } + + my $tree = $cat->tree; + my $cats; +# When root = 0, max_depth is kind of weird because there isn't actually a Category with ID = 0. +# Because of this GT::SQL::Tree doesn't handle the case where max_depth = 1 and root = 0, so +# we'll handle it ourselves. + if ($root == 0 and $CFG->{newsletter_max_depth} == 1) { + $cat->select_options("ORDER BY Full_Name"); + $cats = $cat->select({ FatherID => 0 })->fetchall_hashref; + } + else { + $cats = $tree->children(id => $root, max_depth => ($root == 0 ? $CFG->{newsletter_max_depth} - 1 : $CFG->{newsletter_max_depth}), sort_col => 'Full_Name'); + } +# Insert the root category as the first element + splice @$cats, 0, 0, $root_cat; + my @parents; + my %catids; + for (0 .. $#$cats) { + my $c = $cats->[$_]; +# ID to $cats index mapping + $catids{$c->{ID}}->{index} = $_; +# List of children (only ones which are shown in the trimmed tree) + $catids{$c->{ID}}->{children} = []; +# Fix CatDepth to be relative to $root + if ($_) { + $c->{CatDepth} -= $root_cat->{CatDepth}; + } + +# Keep track of categories which could have sub categories (that are past max_depth) + if ($CFG->{newsletter_max_depth} > 0 and $c->{CatDepth} == $CFG->{newsletter_max_depth}) { + $catids{$c->{ID}}->{check_child}++; + } + else { + $c->{HasMoreChildren} = 0; + } + $c->{Subscribed} = 0; + +# Find all the children + while (@parents and @parents > $c->{CatDepth}) { + my $p = pop @parents; + for (@parents) { + push @{$catids{$_}->{children}}, $p; + } + } + push @parents, $c->{ID}; + } + while (@parents) { + my $p = pop @parents; + for (@parents) { + push @{$catids{$_}->{children}}, $p; + } + } + $cats->[0]->{CatDepth} = 0; + + if (%catids) { + for (keys %catids) { + $cats->[$catids{$_}->{index}]->{Children} = $catids{$_}->{children}; + } + +# Figure out which categories the user has subscribed to + my @subscribed = $ns->select('CategoryID', { UserID => $USER->{Username}, CategoryID => [keys %catids] })->fetchall_list; + for (@subscribed) { + $cats->[$catids{$_}->{index}]->{Subscribed}++; + } + +# Check to see which categories have sub categories + my @check = grep $catids{$_}->{check_child}, keys %catids; + if (@check) { + my $subcats = $tree->child_ids(id => \@check); + for (keys %$subcats) { + $cats->[$catids{$_}->{index}]->{HasMoreChildren} = @{$subcats->{$_}}; + } + } + } + + my %previous = (PPID => ''); + my $parent_subscribed; + if ($root != 0) { + my @parents = @{$tree->parent_ids(id => $root)}; + splice(@parents, 0, 0, 0); + + $parent_subscribed = $ns->count({ UserID => $USER->{Username}, CategoryID => \@parents }); + + my $parent; + if (@parents < $CFG->{newsletter_max_depth}) { + $parent = $parents[0]; + } + else { + $parent = $parents[-$CFG->{newsletter_max_depth}]; + } + +# Get the previous parent's info + if ($parent == 0) { + $parent = _root(); + } + else { + $parent = $cat->select({ ID => $parent })->fetchrow_hashref; + } + %previous = map { "PP" . $_ => $parent->{$_} } keys %$parent; + } + + return { %previous, category => $cats, parent_subscribed => $parent_subscribed }; +} + +sub admin_browse { +# --------------------------------------------------- +# Browse the categories (admin side). +# + my $root = $IN->param('root') || 0; + my $cat = $DB->table('Category'); + my $ns = $DB->table('NewsletterSubscription'); + if ($root != 0 and not $cat->count({ ID => $root })) { + $root = 0; + } + + my $root_cat; + if ($root == 0) { + $root_cat = _root(); + $root_cat->{CatDepth} = -1; + } + else { + $root_cat = $cat->select({ ID => $root })->fetchrow_hashref or return { error => $GT::SQL::error }; + } + + my $tree = $cat->tree; + my $cats; +# root (0) isn't a 'real' category in the tree, so we have to select it ourselves + if ($root == 0 and $CFG->{newsletter_max_depth} == 1) { + $cat->select_options("ORDER BY Full_Name"); + $cats = $cat->select({ FatherID => 0 })->fetchall_hashref; + } + else { + $cats = $tree->children(id => $root, max_depth => ($root == 0 ? $CFG->{newsletter_max_depth} - 1 : $CFG->{newsletter_max_depth}), sort_col => 'Full_Name'); + } +# Insert the root category as the first element of the list of categories + splice @$cats, 0, 0, $root_cat; + + my %catids; + for (0 .. $#$cats) { + my $c = $cats->[$_]; +# ID to $cats index mapping + $catids{$c->{ID}}->{index} = $_; +# List of children (only ones which are shown in the trimmed tree) + $catids{$c->{ID}}->{children} = []; +# Fix CatDepth to be relative to $root + if ($_) { + $c->{CatDepth} -= $root_cat->{CatDepth}; + } + +# Keep track of categories which could have sub categories (that are past max_depth) + if ($CFG->{newsletter_max_depth} > 0 and $c->{CatDepth} == $CFG->{newsletter_max_depth}) { + $catids{$c->{ID}}->{check_child}++; + } + else { + $c->{HasMoreChildren} = 0; + } + $c->{DirectSubscribers} = 0; + } + $cats->[0]->{CatDepth} = 0; + +# Get a list of the root's parents (this is used twice below) + my @root_parents = $root == 0 ? () : (0, @{$tree->parent_ids(id => $root)}); + + if (%catids) { +# Calculate the number of direct subscribers for each category + my %subscribers; + $ns->select_options("GROUP BY CategoryID"); + my $sth = $ns->select('CategoryID', 'COUNT(*)', { CategoryID => [@root_parents, keys %catids] }); + while (my ($catid, $count) = $sth->fetchrow_array) { + if (exists $catids{$catid}) { + $cats->[$catids{$catid}->{index}]->{DirectSubscribers} = $count; + } +# Save the counts to calculate the total subscribers + $subscribers{$catid} = $count; + } + +# Calculate the number of subscribers for each category (if a newsletter was +# sent to this category, it would go to this many people) + my $parents = $tree->parent_ids(id => [keys %catids]); + for my $catid (keys %$parents) { + for (@{$parents->{$catid}}, $catid) { + $cats->[$catids{$catid}->{index}]->{Subscribers} += $subscribers{$_}; + } + $cats->[$catids{$catid}->{index}]->{Subscribers} += $subscribers{0} if $catid; + } + +# Check to see which categories have sub categories + my @check = grep $catids{$_}->{check_child}, keys %catids; + if (@check) { + my $subcats = $tree->child_ids(id => \@check); + for (keys %$subcats) { + $cats->[$catids{$_}->{index}]->{HasMoreChildren} = @{$subcats->{$_}}; + } + } + } + + my %previous = (PPID => ''); + if ($root != 0) { + my $parent; + if (@root_parents < $CFG->{newsletter_max_depth}) { + $parent = $root_parents[0]; + } + else { + $parent = $root_parents[-$CFG->{newsletter_max_depth}]; + } + +# Get the previous parent's info + if ($parent == 0) { + $parent = _root(); + } + else { + $parent = $cat->select({ ID => $parent })->fetchrow_hashref; + } + %previous = map { "PP" . $_ => $parent->{$_} } keys %$parent; + } + + return { %previous, category => $cats }; +} + +sub subscriber_info { +# --------------------------------------------------- +# Returns information about the subscribers of a category. +# + my $catid = $IN->param('ID'); + my $direct = $IN->param('direct'); + my $cat = $DB->table('Category'); + my $nsu = $DB->table('NewsletterSubscription', 'Users'); + + if (not defined $catid or not ($catid == 0 or $cat->count({ ID => $catid }))) { + return { error => 'Invalid ID' }; + } + + my $tree = $cat->tree; + my @parents = $direct || $catid == 0 ? ($catid) : (0, @{$tree->parent_ids(id => $catid)}, $catid); + + $nsu->select_options("ORDER BY Username"); + my $subscribers = $nsu->select({ CategoryID => \@parents })->fetchall_hashref; + + return { subscribers => $subscribers }; +} + +sub subscription_info { +# --------------------------------------------------- +# Returns subscription information about a category. +# 0 = not subscribed +# 1 = indirectly subscribed (parent is subscribed) +# 2 = directly subscribed +# + my $catid = $IN->param('ID') || shift; + my $ns = $DB->table('NewsletterSubscription'); + my $tree = $DB->table('Category')->tree; + + if ($ns->count({ UserID => $USER->{Username}, CategoryID => $catid })) { + return { SubscriptionStatus => 2 }; + } + + if ($catid == 0) { + return { SubscriptionStatus => 0 }; + } + + my @parents = (0, @{$tree->parent_ids(id => $catid)}); + my @pids = $ns->select('CategoryID', { UserID => $USER->{Username}, CategoryID => \@parents })->fetchall_list; + if (@pids) { + return { SubscriptionStatus => 1 }; + } + + return { SubscriptionStatus => 0 }; +} + +sub _root { +# --------------------------------------------------- +# Since there is no real root category, return what a select from the Category +# table would return. +# + my $ns = $DB->table('NewsletterSubscription'); + return { + ID => 0, + Name => Links::language('NEWSLETTER_ROOTCAT'), + CatDepth => 0, + Full_Name => Links::language('NEWSLETTER_ROOTCAT'), + Description => '', + Subscribed => $USER->{Username} ? $ns->count({ UserID => $USER->{Username}, CategoryID => 0 }) : 0, + }; +} + +sub _subscribe { +# --------------------------------------------------- +# Subscribe to the categories passed in. +# + my @sub = @_; + return 0 unless @sub; + + my $cat = $DB->table('Category'); + my $ns = $DB->table('NewsletterSubscription'); + my $tree = $cat->tree; + +# Already subscribed to root category + if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) { + return 0; + } + + @sub = sort { $a <=> $b } @sub; + if ($sub[0] == 0) { + @sub = (0); + } + else { +# Filter out the invalid category ID's + my @s = $cat->select('ID', { ID => \@sub })->fetchall_list; +# Filter out categories which are already subscribed to by being a subcat + @sub = (); + my $parents = $tree->parent_ids(id => \@s); + for (@s) { + unless (@{$parents->{$_}} and $ns->count({ UserID => $USER->{Username}, CategoryID => $parents->{$_} })) { + push @sub, $_; + } + } + } + return 0 unless @sub; + +# Subscribing to the root, subscribes you to all, so remove any existing subscriptions. + $ns->delete({ UserID => $USER->{Username} }) if $sub[0] == 0; + + $ns->insert_multiple([qw/UserID CategoryID/], map { [$USER->{Username}, $_] } @sub); + +# Remove any subscribed subcats of the ones we just added + if ($sub[0] != 0) { + my $c = $tree->child_ids(id => \@sub); + my @subcats = map { @{$c->{$_}} } keys %$c; + if (@subcats) { + $ns->delete({ UserID => $USER->{Username}, CategoryID => \@subcats }); + } + } + +# FIXME need to take into account how many were deleted + return scalar @sub; +} + +sub _unsubscribe { +# --------------------------------------------------- +# Unsubscribe from categories passed in. Returns the number of categories +# unsubscribed from. +# + my @unsub = @_; + return 0 unless @unsub; + + return $DB->table('NewsletterSubscription')->delete({ UserID => $USER->{Username}, CategoryID => \@unsub }); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Parallel.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Parallel.pm new file mode 100644 index 0000000..74d861d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Parallel.pm @@ -0,0 +1,284 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Parallel.pm,v 1.8 2005/03/05 01:29:09 brewt 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 Links::Parallel; +# ================================================================== +# A way to get parallel work for ceartain tasks (not thread based). +# + use strict; + +sub new { +#------------------------------------------------------------ +# creats a new class, be sure to take a look at how it can +# be configured +# + my $class = shift; + my %p; + + ref $_[0] ? (%p = %{$_[0]} ) : (%p = @_); + + my $self = {}; + bless $self, $class; + + $self->{max_workunit} = defined ( $p{max_workunit} ) ? $p{max_workunit} : 10; + $self->{min_workunit} = defined ( $p{min_workunit} ) ? $p{min_workunit} : 3; + $self->{max_children} = defined ( $p{max_children} ) ? $p{max_children} : 3; + $self->{child_path} = defined ( $p{child_path} ) ? $p{child_path} : "./child.pl"; + $self->{path_to_perl} = defined ( $p{path_to_perl} ) ? $p{path_to_perl} : "/usr/local/bin/perl"; + $self->{max_children} = defined ( $p{max_children} ) ? $p{max_children} : 3; + + $self->{spawn_delay} = defined ( $p{spawn_delay} ) ? $p{spawn_delay} : 2; + + $self->{to_check} = defined ( $p{to_check} ) ? $p{to_check} : []; + $self->{on_response} = defined ( $p{on_response} ) ? $p{on_response} : sub { }; + + # for statistics + $self->{start_time} = 0; + $self->{end_time} = 0; + $self->{threads_spawned}= 0; + + $self->{threads_stats} = {}; + + return $self; +} + +sub wait { +#------------------------------------------------------------ +# the main loop that waits until the subset is checked. +# + my $self = shift; + my $max_children = $self->{max_children}; + my @active_units = (); + $self->{start_time} = time; + my $temp = 0; + + # while there's stuff to check + while ( ( @{$self->{to_check}} ) or ( @active_units) ) { + # create work units + my $spawned = 0; + while ( ( ($#active_units+1) < $max_children ) and ( @{$self->{to_check}} ) ) { + # if we've already spawned a child, wait one so we don't + # spike the load + sleep $self->{spawn_delay} if $spawned; + $spawned++; + push @active_units, $self->new_work_unit (); + }; + + # wait for any connections, blocking call. + my $rin = fhbits ( \@active_units ); + select ( $rin, undef, undef, undef ); + + # find out who is has input + my ( $i, $wild_protect ); + $i = 0; $wild_protect = 0; + while ( $i <= $#active_units ) { + + # if a unit requires attention, get input or kill it + if ( $active_units[$i]->has_input () ) { + $wild_protect++; + my ( $id, $code, $message ) = $active_units[$i]->get_input (); + if ( defined $id ) { + &{$self->{on_response}}( $id, $code, $message ); + } else { + my ( $unit_id, $start_time, $number_checked, $time_taken ) = $active_units[$i]->get_stats(); + ${$self->{thread_stats}}{$unit_id} = [$start_time, $number_checked, $time_taken]; + $active_units[$i]->end_unit(); + # in case the child aborted abnormally, push the remaining + # urls to be checked onto the stack + push @{$self->{to_check}}, @{$active_units[$i]->{to_check}}; + splice ( @active_units, $i, 1 ); + next; + }; + }; + $i++; + }; + + # protect against wild looping + $wild_protect || die "Error in verifier, looping wildly"; + }; + $self->{end_time} = time; +} + +sub get_stats { +#------------------------------------------------------------ +# Return stats for the thread information. +# + my $self = shift; + return [ $self->{threads_spawned}, $self->{end_time} - $self->{start_time}, $self->{thread_stats} ]; +} + +sub new_work_unit { +#------------------------------------------------------------ +# allocates a new work unit for the chilren +# there are some optimization routines that should at some +# point be implemented (for better allocation of +# work units +# + my $self = shift; + my $num_units = $#{$self->{to_check}}+1; + my $max_children= $self->{max_children}; + my $unit_size = int ( $num_units / ( $max_children + 1 ) ); + + ($unit_size > $self->{max_workunit}) and $unit_size = $self->{max_workunit}; + ($unit_size < $self->{min_workunit}) and $unit_size = $self->{min_workunit}; + ($unit_size > $num_units) and $unit_size = $num_units; + + my @to_check = @{$self->{to_check}}[0..$unit_size-1]; + splice ( @{$self->{to_check}}, 0, $unit_size ); + + $self->{threads_spawned}++; + + return Links::Parallel::WorkUnit->new ( $self->{path_to_perl}, $self->{child_path}, $self->{child_args}, \@to_check ); +} + +sub fhbits { +#------------------------------------------------------------ +# to set the fhandle bits for the impending select call +# + my ($work_units, $bits) = @_; + defined $bits or ($bits = ''); + foreach (@$work_units) { + vec($bits,$_->fno(),1) = 1; + }; + return $bits; +} + +##################################################### +package Links::Parallel::WorkUnit; + +use FileHandle; +use strict; +my $clwork_units = 0; + +sub new { +#------------------------------------------------------------ +# creates a new work unit, starts up the child process +# and encapsulats all the required data..., +# + my ($class, $perlpath, $child, $cmdline, $to_check, $verbosity) = @_; + my $self = {}; + $self->{verbosity} = $verbosity || 1; + ($self->{istream}, $self->{pid}) = new_handle ( $perlpath, $child, $cmdline, $to_check ); + @{$self->{to_check}} = @$to_check; + @{$self->{checked}} = (); + $self->{unitid} = $clwork_units++; + $self->{start_time} = time; + $self->{number_checked} = 0; + bless $self, $class; + + return $self; +} + +sub new_handle { +#------------------------------------------------------------ +# the function that actually creates a new child process +# + my ($perlpath, $child, $cmdline, $to_check, $verbosity) = @_; + $verbosity ||= 1; + + my $newfh = new FileHandle; + my $pid = 0; + $cmdline ||= ''; + $, = "|"; + + if ($verbosity) { + print "Launching new child ... "; + } + if (-e $child) { + $pid = $newfh->open ( "$perlpath $child $cmdline @$to_check |" ); + if ((!$pid)or($?)) { die "Error launching child '$perlpath $child $cmdline'. Status: $?"; } + } else { + die "Child ($child) must exist"; + } + print "ok ($pid)\n"; + return ( $newfh, $pid ); +} + +sub fno { +#------------------------------------------------------------ +# returns the file handle, useful when using the +# "select" call +# + my $self = shift; + return fileno ( $self->{istream} ); +} + +sub has_input { +#------------------------------------------------------------ +# returns whether or not this workunit has anything to +# report to the parent +# + my $self = shift; + my $rin = ''; + vec ( $rin, $self->fno(), 1 ) = 1; + my $s = select ( $rin, undef, undef, 0 ); + return $s; +} + +sub get_input { +#------------------------------------------------------------ +# process the local input. +# this is only here because we want to make sure that +# the work unit keeps track of it's own work pool +# this frees the task administrator to do it's real +# work and helps with crash recovery +# + my $self = shift; + my $fh = $self->{istream}; + $fh || die "not defined!"; + my $str = <$fh>; + if ( defined ( $str ) ) { + chop $str; + $str =~ /\s*([0-9]+)\t([-0-9]*)\t(.*)/; + push @{$self->{checked}}, $1; + splice @{$self->{to_check}}, 0, 1; + $self->{number_checked}++; + return ( $1, $2, $3 ); + } else { + $self->end_unit (); + return; + }; +} + +sub get_stats { +#------------------------------------------------------------ +# Display statistic information. +# + my $self = shift; + return ( $self->{unitid}, $self->{start_time}, $self->{number_checked}, time-$self->{start_time} ); +} + +sub end_unit { +#------------------------------------------------------------ +# prepares the WorkUnit for deallocation. Note how +# there is a force -9 kill, without that, perl will wait +# until the child finishes on it's own, which might be +# soon, later or in a 100 years +# + my $self = shift; + my $fh = $self->{istream}; + + kill 9, ( $self->{pid} ); + $self->{istream}->close (); +} + +sub DESTROY { +#------------------------------------------------------------ +# deallocs the object +# we want perl to force kill the child so we can ensure we exit +# quickly + my $self = shift; + $self->end_unit; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm new file mode 100644 index 0000000..0fa78f3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm @@ -0,0 +1,1663 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Payment.pm,v 1.84 2012/02/02 08:51:47 brewt 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. +# ================================================================== + +# Terminology: +# payment_type: signup (0), renewal (1), recurring (2) +# payment_term: 1y, 2y, etc +# payment_method: PayPal, WorldPay, AuthorizeDotNet, Moneris, etc +# payment_method_type: direct or remote + +package Links::Payment; + +# Pragmas +use strict; +use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS %Ptd %Lang_map/; + +# Internal Modules +use Links qw/:objects :payment/; +use GT::AutoLoader; +use GT::Date qw/timelocal/; +use Exporter; + +use constants + PENDING => 0, + COMPLETED => 1, + DECLINED => 2, + ERROR => 3, + + INITIAL => 0, + RENEWAL => 1, + RECURRING => 2, + + LOG_INFO => 0, + LOG_ACCEPTED => 1, + LOG_DECLINED => 2, + LOG_ERROR => 3, + LOG_MANUAL => 4; + + +@ISA = qw(Exporter Links); # Inherit from Exporter and Links +@EXPORT_OK = qw/PENDING COMPLETED DECLINED ERROR LOG_INFO LOG_ACCEPTED LOG_DECLINED LOG_ERROR LOG_MANUAL/; +%EXPORT_TAGS = ( + status => [qw/PENDING COMPLETED DECLINED ERROR/], + log => [qw/LOG_INFO LOG_ACCEPTED LOG_DECLINED LOG_ERROR LOG_MANUAL/], + all => \@EXPORT_OK +); + +%Ptd = ( + d => 1, + w => 7, + m => 30, + y => 365 +); + +%Lang_map = ( + d => 'DATE_UNIT_DAY', + w => 'DATE_UNIT_WEEK', + m => 'DATE_UNIT_MONTH', + y => 'DATE_UNIT_YEAR' +); + +$COMPILE{method} = __LINE__ . <<'END_OF_SUB'; +sub method { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $term = _check_term(scalar $IN->param('payment_term')); + return $self->error($term, 'WARN') unless ref $term; + my $methods; + if ($term->{recurring}) { + $methods = $self->methods(1, 1); + } + else { + $methods = $self->methods(0, 1); + } + return $self->error($term, 'WARN') unless ref $term; + +# If we only have one usable payment method, just pass the user onto the +# payment form. + if (@{$methods->{payment_methods}} == 1) { + $IN->param(payment_method => ($methods->{payment_methods}->[0]->{payment_direct} ? "direct_" : "remote_") . $methods->{payment_methods}->[0]->{payment_method}); + $IN->param(page => 'payment_form'); + return $self->form(); + } + + return { + %$methods, + payment_name => $term->{name}, + payment_description => $CFG->{payment}->{description}, + payment_term => $term->{term}, + payment_term_num => $term->{term_num}, + payment_term_u => $term->{term_unit}, + payment_term_unit => $term->{term_unit} && Links::language($Lang_map{$term->{term_unit}} . ($term->{term_num} != 1 ? 'S' : '')), + payment_amount => $term->{amount}, + payment_type => $term->{recurring} ? 2 : $term->{type} eq 'renewal' ? 1 : 0, + }; +} +END_OF_SUB + +$COMPILE{form} = __LINE__ . <<'END_OF_SUB'; +sub form { +# ----------------------------------------------------------------------------- +# + my $self = shift; + my @vars; + + my $term = _check_term(scalar $IN->param('payment_term')); + return $self->error($term, 'WARN') unless ref $term; + my $payment_vars = { + payment_term => $term->{term}, + payment_term_num => $term->{term_num}, + payment_term_u => $term->{term_unit}, + payment_term_unit => $term->{term_unit} && Links::language($Lang_map{$term->{term_unit}} . ($term->{term_num} != 1 ? 'S' : '')), + payment_amount => $term->{amount}, + payment_type => $term->{recurring} ? 2 : 1, + payment_name => $term->{name}, + payment_description => $CFG->{payment}->{description}, + }; + + my $method = _check_method($term->{recurring}, scalar $IN->param('payment_method'), scalar $IN->param('payment_method_type')); + return $self->error($method, 'WARN', $payment_vars) unless ref($method); + + my $method_info = _method($method->{method}, $method->{method_type} eq 'direct'); + push @vars, {%$method_info}; + + if ($method->{method_type} eq 'remote') { + my $payment_unique = generate_unique_id(); + my $link_id = $IN->param('link_id'); + if (!$CFG->{user_required}) { + $DB->table('Links')->count({ ID => $link_id }) or return $self->error('PAYMENTERR_INVALIDLINKID', 'WARN'); + } + elsif (!$DB->table('Links')->count({ ID => $link_id, LinkOwner => $USER->{Username} })) { + return $self->error('PAYMENTERR_INVALIDLINKID', 'WARN'); + } + $DB->table('Payments')->insert({ + payments_linkid => $link_id, + payments_id => $payment_unique, + payments_status => PENDING, + payments_method => $method->{method_type} . '_' . $method->{method}, + payments_type => $term->{type} eq 'recurring' ? RECURRING : $term->{type} eq 'renewal' ? RENEWAL : INITIAL, + payments_amount => $term->{amount}, + payments_term => $term->{term}, + payments_start => time, + payments_last => time, + }) or die "Insert failed (No payment was charged): $GT::SQL::error"; + push @vars, { unique_id => $payment_unique }; + } + + $payment_vars->{payment_method_type} = $method->{method_type}; + push @vars, $payment_vars; + + my $pkg = $method_info->{payment_package}; + require $method_info->{payment_module}; + my $meth_info = $pkg->can('payment_info') ? $pkg->payment_info() : {}; + push @vars, {%$meth_info}; + + return { map { %$_ } @vars }; +} +END_OF_SUB + +$COMPILE{direct} = __LINE__ . <<'END_OF_SUB'; +sub direct { +# ----------------------------------------------------------------------------- +# + my $self = shift; + + my $term = _check_term(scalar $IN->param('payment_term')); + return $self->error($term, 'WARN') unless ref($term); + + my $method = _check_method($term->{recurring}, scalar $IN->param('payment_method'), scalar $IN->param('payment_method_type')); + return $self->error($method, 'WARN') unless ref($method); + + my $pkg = $CFG->{payment}->{$method->{method_type}}->{methods}->{$method->{method}}->{package}; + require $CFG->{payment}->{$method->{method_type}}->{methods}->{$method->{method}}->{module}; + + my $payment_unique = generate_unique_id(); + $IN->param(order_id => $payment_unique); + $IN->param(charge_total => $term->{amount}); + my $verify = $pkg->verify(); +# An array reference return value indicates that the fields in the array +# reference had incorrect values. + if (ref $verify eq 'ARRAY') { + my %errors; + for (@{$verify->[0]}, @{$verify->[1]}) { + $errors{$_ . "_error"}++; + } + if (exists $errors{credit_card_expiry_month_error} or exists $errors{credit_card_expiry_year_error}) { + $errors{credit_card_expiry_error}++; + } + return $self->error('PAYMENTERR_DIRECT', 'WARN', \%errors) if keys %errors; + } + + my $pt = $DB->table('Payments'); + my $pl = $DB->table('PaymentLogs'); + my $link_id = $IN->param('link_id'); + if (!$CFG->{user_required}) { + $DB->table('Links')->count({ ID => $link_id }) or return $self->error('PAYMENTERR_INVALIDLINKID', 'WARN'); + } + elsif (!$DB->table('Links')->count({ ID => $link_id, LinkOwner => $USER->{Username} })) { + return $self->error('PAYMENTERR_INVALIDLINKID', 'WARN'); + } + $pt->insert({ + payments_linkid => $link_id, + payments_id => $payment_unique, + payments_status => PENDING, + payments_method => $method->{method_type} . '_' . $method->{method}, + payments_type => $term->{type} eq 'recurring' ? RECURRING : $term->{type} eq 'renewal' ? RENEWAL : INITIAL, + payments_amount => $term->{amount}, + payments_term => $term->{term}, + payments_start => time, + payments_last => time, + }) or die "Insert failed (No payment was charged): $GT::SQL::error"; + +# Actually perform the direct payment: + my ($complete, $message, $receipt) = $pkg->complete(); + if ($complete == 1) { + $pt->update({ payments_status => COMPLETED, payments_last => time }, { payments_id => $payment_unique }); + $pl->insert({ + paylogs_payments_id => $payment_unique, + paylogs_type => LOG_ACCEPTED, + paylogs_time => time, + paylogs_text => $message . "\n\nReceipt:\n$receipt" + }); + process_payment($IN->param('link_id'), $term->{term}, 0); + } + elsif ($complete == 0) { + $pt->update({ payments_status => DECLINED, payments_last => time }, { payments_id => $payment_unique }); + $pl->insert({ + paylogs_payments_id => $payment_unique, + paylogs_type => LOG_DECLINED, + paylogs_time => time, + paylogs_text => $message + }); + return $self->error('PAYMENTERR_DECLINED', 'WARN', { payment_declined => 1, payment_errmsg => $message }); + } + else { + $pt->update({ payments_status => ERROR, payments_last => time }, { payments_id => $payment_unique }); + $pl->insert({ + paylogs_payments_id => $payment_unique, + paylogs_type => LOG_ERROR, + paylogs_time => time, + paylogs_text => $message + }); + return $self->error('PAYMENTERR_DIRECT', 'WARN', { payment_erred => 1, payment_errmsg => $message }); + } + + return {}; +} +END_OF_SUB + +$COMPILE{confirm} = __LINE__ . <<'END_OF_SUB'; +sub confirm { +# ----------------------------------------------------------------------------- +# + my $self = shift; + return {}; +} +END_OF_SUB + +$COMPILE{_check_term} = __LINE__ . <<'END_OF_SUB'; +sub _check_term { +# ----------------------------------------------------------------------------- +# Checks that a payment term is valid and either returns an error string, or a hash +# of information that has been parsed from the input. +# + my $payment_term = shift; + my ($term, $term_num, $term_unit, $rec, $type, $lifetime, $cost); + my $cat_id = $IN->param('cat_id'); + ($cat_id =~ /^\d+$/) or return 'PAYMENTERR_INVALIDCATID'; + my $conf = load_cat_price($cat_id); # load payment terms for this category + if ($payment_term) { + if ($payment_term =~ m/^(?:(\d+)([dwmy])|(\w+))(?:-(\w+))?$/) { + $term_num = $1; + $term_unit = $2; + $lifetime = $3; + $rec = $4; + $term = $term_num ? "$term_num$term_unit" : $lifetime; + } + if ($rec) { + $type = 'recurring'; + } + else { + my $link_expiry = $DB->table('Links')->select(ExpiryDate => { ID => scalar $IN->param('link_id') })->fetchrow; + if ($link_expiry == UNPAID or $link_expiry == FREE) { + $type = 'signup' + } + else { + $type = 'renewal'; + } + } + +# Check that the payment term actually exists + if ($conf->{payment_mode} and $conf->{term_cnt}) { + my $cond; + $cond->{cp_cat_id_fk} = $cat_id; + $cond->{cp_term} = $term; + $rec and $cond->{cp_type} = '2';# 2 = recurring + my $db_term = $DB->table('CatPrice')->select($cond)->fetchrow_hashref; + $db_term or return 'PAYMENTERR_INVALIDTERM'; + $cost = $db_term->{cp_cost}; + } + else{ + unless ((!$rec and exists $CFG->{payment}->{term}->{types}->{signup}->{$term}) or + (!$rec and exists $CFG->{payment}->{term}->{types}->{renewal}->{$term}) or + ($rec and exists $CFG->{payment}->{term}->{types}->{recurring}->{$term})) { + return 'PAYMENTERR_INVALIDTERM'; + } + $cost = ($type eq 'renewal' and !exists $CFG->{payment}->{term}->{types}->{$type}->{$term}) + ? $CFG->{payment}->{term}->{types}->{signup}->{$term} + : $CFG->{payment}->{term}->{types}->{$type}->{$term}; + } + + } + else { + return 'PAYMENTERR_NOLEVEL'; + } + +# Check payment discount and adjust the cost + my $discount = check_discount(); + $discount and $cost and $cost = $cost * (100 - $discount->{percent}) / 100; + $cost = sprintf("%.2f", $cost); + return { + %$conf, + term => $payment_term, + term_num => $term_num, + term_unit => $term_unit, + recurring => $rec, + type => $type, + lifetime => $lifetime, + amount => $cost + }; +} +END_OF_SUB + +$COMPILE{_check_method} = __LINE__ . <<'END_OF_SUB'; +sub _check_method { +# ----------------------------------------------------------------------------- +# Checks that a method is valid and either returns an error string, or a hash +# of information that has been parsed from the input. +# +# The first argument is whether or not the selected payment is a recurring +# type or not. The third argument, method_type_in, is optional. If it is not +# supplied, then method_in must be in format _. +# + my ($recurring, $method_in, $method_type_in) = @_; + + my ($method_type, $method); + if ($method_in) { + if ($method_type_in) { + $method = $method_in; + $method_type = $method_type_in; + } + else { + ($method_type, $method) = split(/_/, $method_in, 2); + } + unless (exists $CFG->{payment}->{$method_type} and exists $CFG->{payment}->{$method_type}->{used}->{$method}) { + return 'PAYMENTERR_INVALIDMETHOD'; + } + + if ($recurring and !$CFG->{payment}->{$method_type}->{methods}->{$method}->{recurring}) { + return 'PAYMENTERR_INVALIDMETHOD'; + } + } + else { + return 'PAYMENTERR_NOMETHOD'; + } + + return { + method_type => $method_type, + method => $method, + }; +} +END_OF_SUB + +$COMPILE{load_config} = __LINE__ . <<'END_OF_SUB'; +sub load_config { +# ----------------------------------------------------------------------------- +# Loads information from config file, and returns it to a template. +# + my ($self) = @_; + my $conf; + my $term = {%{$CFG->{payment}->{term}}}; + my $discount = check_discount(); + for my $type (keys %{$term->{types}}) { + my @terms; + for my $item (sort { convert_to_days($a) <=> convert_to_days($b) } keys %{$term->{types}->{$type}}) { + my ($num, $unit) = $item =~ m/^(\d+)([dwmy])$/; + my $cost = $term->{types}->{$type}->{$item}; + $discount and $cost and $cost = $cost*(100-$discount->{percent})/100; + push @terms, { + term => $item, + term_num => $num, + term_unit => $unit && Links::language($Lang_map{$unit} . ($num != 1 ? 'S' : '')), + cost => sprintf("%.2f", $cost), + }; + } + + $conf->{$type} = \@terms; + $conf->{"num_$type"} = @terms; + } +# If no renewal terms are defined, use the signup terms + if (not $conf->{renewal} or not $conf->{num_renewal}) { + $conf->{renewal} = [@{$conf->{signup}}]; + for (my $i = 0; $i < @{$conf->{renewal}}; $i++) { + if ($conf->{renewal}->[$i]->{cost} == 0) { + splice @{$conf->{renewal}}, $i--, 1; + } + } + $conf->{num_renewal} = @{$conf->{renewal}}; + $conf->{renewal_differs} = undef; + } + else { + $conf->{renewal_differs} = 1; + } + +# Load discounts + my $discounts = $CFG->{payment}->{discounts}; + my @payment_discounts; + for my $num (sort { $a <=> $b } keys %$discounts) { + push @payment_discounts, { + num => $num, + percent => $discounts->{$num}->{percent}, + description => $discounts->{$num}->{description} + }; + } + $conf->{payment_discounts} = \@payment_discounts if @payment_discounts; + +# Load other info + $conf->{payment_enabled} = ( + $CFG->{payment}->{enabled} and ( + keys %{$CFG->{payment}->{remote}->{used}} + or + keys %{$CFG->{payment}->{direct}->{used}} + ) + ); + $conf->{payment_config_enabled} = $CFG->{payment}->{enabled}; + $conf->{payment_mode} = $CFG->{payment}->{mode}; + $conf->{payment_auto_validate} = $CFG->{payment}->{auto_validate}; + $conf->{payment_description} = $CFG->{payment}->{description}; + $conf->{payment_expiry_notify} = $CFG->{payment}->{expiry_notify}; + $conf->{payment_expired_is_free} = $CFG->{payment}->{expired_is_free}; + + return $conf; +} +END_OF_SUB + + +$COMPILE{save_config} = __LINE__ . <<'END_OF_SUB'; +sub save_config { +# ----------------------------------------------------------------------------- +# + + + my $save; + for (qw/enabled mode auto_validate description expired_is_free/) { + if ($CFG->{payment}->{$_} ne (my $v = $IN->param("payment_$_"))) { + $CFG->{payment}->{$_} = $v; + $save++; + } + } + if ($CFG->{payment}->{expiry_notify} ne (my $v = $IN->param('payment_expiry_notify') || 7)) { + $CFG->{payment}->{expiry_notify} = $v; + $save++; + } + +# Handle any deletions + for ($IN->param('delete_discount')) { + if (exists $CFG->{payment}->{discounts}->{$_}) { + delete $CFG->{payment}->{discounts}->{$_}; + $save++; + } + } + for my $p ($IN->param) { + if ($p =~ /^delete_(signup|renewal|recurring)$/) { + my $type = $1; + for my $item ($IN->param($p)) { + if (exists $CFG->{payment}->{term}->{types}->{$type}->{$item}) { + delete $CFG->{payment}->{term}->{types}->{$type}->{$item}; + $save++; + } + } + } + } + +# Add new term + my $new_fee = $IN->param('signup_cost'); + my $term_length = $IN->param('term_length'); + my $term_unit = $IN->param('term_unit'); + my $add_type = $IN->param('add_type') || 'signup'; + my $trying = length($new_fee) + length($term_length); + my $ok; + + if (!$trying or ($term_unit eq 'unlimited' and $add_type ne 'recurring') or ( + $term_length =~ /^(\d+)$/ and $term_length > 0 and + $term_unit =~ /^[dwmy]$/) + ) { + $ok = 1; + } + else { + return { payment_config_invalid_term => 1 }; + } + if (!$trying or $new_fee =~ /^(\d+\.\d\d|\.\d\d|\d+)$/ and $new_fee > 0) { + $ok = 1; + } + else { + return { payment_config_invalid_fee => 1 }; + } + if ($trying and $ok) { + $CFG->{payment}->{term}->{types}->{$add_type}->{$term_unit eq 'unlimited' ? 'unlimited' : "$term_length$term_unit"} = sprintf "%.2f", $new_fee; + $save++; + } + +# Add a new payment discount + my $num_links = $IN->param('discount_num_links'); + my $description = $IN->param('discount_description'); + my $percent = scalar $IN->param('discount_percent') || 0; + if ($num_links or $percent) { + if (($num_links =~ /^(\d+)$/) and ($num_links > 1) and (($percent =~ /^(\d?\d)$/) and ($percent > 0) and ($percent < 100))) { + $CFG->{payment}->{discounts}->{$num_links} = { + description => $description, + percent => $percent + }; + $save++; + } + else { + return { payment_config_invalid_discount => 1 }; + } + } + $CFG->save() if $save; + return { config_saved_done => 1 }; +} +END_OF_SUB + +sub direct_methods_used { + return ( + $CFG->{payment}->{enabled} and + keys %{$CFG->{payment}->{direct}->{used}} + ); +} + +$COMPILE{cat_payment_info} = __LINE__ . <<'END_OF_SUB'; +sub cat_payment_info { +# ----------------------------------------------------------------------------- +# Loads payment mode from database for a specific category or from global config. +# Used in displaying a category or search_results function +# IN : Category ID +# OUT: mode => 0|1|2 (Not Accepted|Optional|Required) +# or error => Error messages +# + my $cat_id = shift; + my $ret; + $ret->{mode} = $CFG->{payment}->{mode}; + +# Get category info + if ($cat_id =~ /^\d+$/) { + my $cat = $DB->table('Category')->get($cat_id) or return { error => Links::language('PAYMENTERR_INVALIDCATID') }; + $cat->{Payment_Mode} and $ret->{mode} = $cat->{Payment_Mode}; + } + return $ret; +} +END_OF_SUB + +$COMPILE{load_cat_price} = __LINE__ . <<'END_OF_SUB'; +sub load_cat_price { +# ----------------------------------------------------------------------------- +# Loads payment terms from database for a particular category and returns it to a template. +# + my ($cat_id) = @_; + my $data; + my $out; + + if (ref $cat_id and @$cat_id == 1) { + $cat_id = $cat_id->[0]; + } +# If more than one category is passed in, then a single category needs to be chosen. + elsif (ref $cat_id) { + my $category = $DB->table('Category'); +# Order the results so we get consistent results + $category->select_options('ORDER BY ID'); + my $sth = $category->select('ID', 'Payment_Mode', { ID => $cat_id }); + my $modes; + while (my $row = $sth->fetchrow_hashref) { + push @{$modes->{$row->{Payment_Mode}}}, $row->{ID}; + if ($row->{Payment_Mode} == GLOBAL) { + push @{$modes->{$CFG->{payment}->{mode}}}, $row->{ID}; + } + } + +# Choose the global payment terms over custom one which a global payment term exists + if (exists $modes->{REQUIRED . ''}) { + if ($CFG->{payment}->{mode} == REQUIRED and exists $modes->{GLOBAL . ''}) { + $cat_id = $modes->{GLOBAL . ''}->[0]; + } + else { + $cat_id = $modes->{REQUIRED . ''}->[0]; + } + } + elsif (exists $modes->{OPTIONAL . ''}) { + if ($CFG->{payment}->{mode} == OPTIONAL and exists $modes->{GLOBAL . ''}) { + $cat_id = $modes->{GLOBAL . ''}->[0]; + } + else { + $cat_id = $modes->{OPTIONAL . ''}->[0]; + } + } + elsif (exists $modes->{NOT_ACCEPTED . ''}) { + $cat_id = $modes->{NOT_ACCEPTED . ''}->[0]; + } + } + +# Get category info + ($cat_id =~ /^\d+$/) or return { payment_invalid_cat_id => 1 }; + $out = $DB->table('Category')->select({ ID => $cat_id })->fetchrow_hashref; +# Only check for existing category payment terms if the category's Payment_Mode isn't using the global terms + if ($out->{Payment_Mode}) { + $out->{term_cnt} = $DB->table('CatPrice')->count({ 'cp_cat_id_fk' => $cat_id }); + } +# Payment_Mode allows the category to override the global setting (0 = use global setting) + $out->{payment_mode} = $out->{Payment_Mode} || $CFG->{payment}->{mode}; + $out->{payment_description} = $CFG->{payment}->{description}; + +# If we need to check global config, or if no payments are defined for this category + if (!$IN->param('not_global') and (!$out->{Payment_Mode} or !$out->{term_cnt})) { + my $conf = load_config(); + foreach (keys %$conf) { + !exists $out->{$_} and $out->{$_} = $conf->{$_} + } + } +# Otherwise load info from database + else { + my $db = $DB->table('CatPrice'); + my $sth = $db->select({ 'cp_cat_id_fk' => $cat_id }); + while (my $term = $sth->fetchrow_hashref) { + push @$data => _get_term($term); + } + for my $type (qw/signup renewal recurring/) { + my @terms = grep {$_->{type} eq $type} sort { convert_to_days($a->{term}) <=> convert_to_days($b->{term}) } @$data; + $out->{$type} = \@terms if @terms; + $out->{"num_$type"} = @terms; + } + +# If no renewal terms are defined, use the signup terms + if (not $out->{renewal} or not $out->{num_renewal}) { + $out->{renewal} = [@{$out->{signup}}]; + for (my $i = 0; $i < @{$out->{renewal}}; $i++) { + if ($out->{renewal}->[$i]->{cost} == 0) { + splice @{$out->{renewal}}, $i--, 1; + } + } + $out->{num_renewal} = @{$out->{renewal}}; + $out->{renewal_differs} = undef; + } + else { + $out->{renewal_differs} = 1; + } + } + +# Return some values for using in templates + $out->{cat_id} = $cat_id; + my $discount = check_discount(); + defined $discount->{percent} and $out->{discount_percent} = $discount->{percent}; + defined $discount->{description} and $out->{discount_description} = $discount->{description}; + + return $out; +} +END_OF_SUB + +$COMPILE{save_cat_price} = __LINE__ . <<'END_OF_SUB'; +sub save_cat_price { +# ----------------------------------------------------------------------------- +# Store payment terms for a particular category into database +# + + my $cgi = $IN->get_hash; + my $save; + my $dels = $cgi->{delete_term}; + ref $dels or $dels = [$dels]; + foreach my $id (@$dels) { + $DB->table('CatPrice')->delete($id) and $save++; + } +# Add new term + my $new_fee = $IN->param('signup_cost'); + my $term_length = $IN->param('term_length'); + my $term_unit = $IN->param('term_unit'); + my $add_type = $IN->param('add_type') || 'signup'; + my $trying = length($new_fee) + length($term_length); + my $ok; + my $cat_id = $IN->param('ID'); + ($cat_id =~ /^\d+$/) or return { payment_invalid_cat_id => 1 }; + +# Copy global terms + if ($IN->param('copy_global')) { + my $types = $CFG->{payment}->{term}->{types}; + foreach my $type (keys %$types) { + my $cp_type = $type eq 'recurring' ? 2 : $type eq 'renewal' ? 1 : 0; + foreach my $term (keys %{$types->{$type}}) { + my $new_term; + $new_term->{cp_term} = $term; + $new_term->{cp_cat_id_fk} = $cat_id; + $new_term->{cp_type} = $cp_type; + $DB->table('CatPrice')->count($new_term) and next ; + $new_term->{cp_cost} = sprintf "%.2f", $types->{$type}->{$term}; + $DB->table('CatPrice')->add($new_term) or die "$GT::SQL::error"; + } + } + return { config_copied_done => 1}; + } + + + if (!$trying or ($term_unit eq 'unlimited' and $add_type ne 'recurring') or ( + $term_length =~ /^(\d+)$/ and $term_length > 0 and + $term_unit =~ /^[dwmy]$/) + ) { + $ok = 1; + } + else { + return { payment_config_invalid_term => 1 }; + } + if (!$trying or $new_fee =~ /^(\d+\.\d\d|\.\d\d|\d+)$/ and $new_fee > 0) { + my $term_cnt = $DB->table('CatPrice')->count({ + cp_term => $term_unit eq 'unlimited' ? 'unlimited' : "$term_length$term_unit", + cp_cat_id_fk => $cat_id, + cp_type => $add_type eq 'recurring' ? 2 : $add_type eq 'renewal' ? 1 : 0 + }); + $term_cnt and return { payment_term_exists => 1 }; + $ok = 1; + } + else { + return { payment_config_invalid_fee => 1 }; + } + if ($trying and $ok) { + my $input; + $input->{cp_cat_id_fk} = $cat_id; + $input->{cp_type} = $add_type eq 'recurring' ? 2 : $add_type eq 'renewal' ? 1 : 0; + $input->{cp_term} = $term_unit eq 'unlimited' ? 'unlimited' : "$term_length$term_unit"; + $input->{cp_cost} = sprintf "%.2f", $new_fee; + my $cp_id = $DB->table('CatPrice')->add($input) or die "$GT::SQL::error"; + $save++; + } + $save and return { config_saved_done => 1}; + return; +} +END_OF_SUB + +$COMPILE{check_expiry_date} = __LINE__ . <<'END_OF_SUB'; +sub check_expiry_date { +# ----------------------------------------------------------------------------- +# Make sure that the ExpiryDate of a link is valid for the category/categories +# that the link is in. +# +# A link ID or a hash of link data (that has the original ExpiryDate) is +# required and the array ref of categories the link is in is optional. A new +# ExpiryDate is returned if the current one is invalid. +# + my ($link, $cats) = @_; + + if ($CFG->{payment}->{enabled}) { + $link = ref $link ? $link : $DB->table('Links')->select('ExpiryDate', { ID => $link })->fetchrow; + $cats ||= [$IN->param('CatLinks.CategoryID')]; + + my $modes; + my $category = $DB->table('Category'); + $category->select_options('GROUP BY Payment_Mode'); + my $sth = $category->select('Payment_Mode', { ID => $cats }); + while (defined(my $mode = $sth->fetchrow)) { + $modes->{$mode == GLOBAL ? $CFG->{payment}->{mode} : $mode}++; + } + +# If any of the categories the link is in requires payment, then payment is required + if (exists $modes->{REQUIRED . ''}) { +# Every ExpiryDate value is valid except for FREE + return UNPAID if $link->{ExpiryDate} == FREE; + } +# Payments are optional in one or more categories, ExpiryDate can be set to anything + elsif (exists $modes->{OPTIONAL . ''}) { + return; + } +# No payments are accepted for any of the categories, the ExpiryDate should be set to FREE + elsif (exists $modes->{NOT_ACCEPTED . ''}) { + return FREE if $link->{ExpiryDate} != FREE; + } + } + return; +} +END_OF_SUB + +sub _get_term { +# ----------------------------------------------------------------------------- +# Prepare a term (from database) to return to the template +# + my $term = shift; + my $ret; + ($ret->{term_num}, $ret->{term_unit}) = $term->{cp_term} =~ m/^(\d+)([dwmy])$/; + $ret->{term} = $term->{cp_term}; + $ret->{term_unit} = $ret->{term_unit} && Links::language($Lang_map{$ret->{term_unit}} . ($ret->{term_num} != 1 ? 'S' : '')); + my $discount = check_discount(); + $discount and $term->{cp_cost} and $term->{cp_cost} = $term->{cp_cost}*(100-$discount->{percent})/100; + $ret->{cost} = sprintf("%.2f", $term->{cp_cost}); + $ret->{type} = $term->{cp_type} eq '2' ? 'recurring' : $term->{cp_type} eq '1' ? 'renewal' : 'signup'; + $ret->{cp_id} = $term->{cp_id}; + return $ret; +} + + +$COMPILE{methods} = __LINE__ . <<'END_OF_SUB'; +sub methods { +# ----------------------------------------------------------------------------- +# Returns template loop variables 'payment_methods'. Loop variables available: +# payment_direct: 1 (direct) or 0 (remote) +# payment_name: 'Authorize.Net', 'Moneris', 'PayPal', et cetera +# payment_module: 'AuthorizeDotNet', 'Moneris', 'PayPal', et cetera +# payment_used: 1 (used), 0 (not used) +# +# You may optionally pass in a true value in order to only return payment +# methods capable of handling recurring payments. A second value, if true, +# indicates that you want only enabled methods. +# + my ($self, $want_recurring, $want_used) = @_; + my @methods; + my ($used_direct, $used_remote) = (0, 0); + my ($d, $r) = @{$CFG->{payment}}{'direct', 'remote'}; + + for my $w ($d, $r) { + for (sort keys %{$w->{methods}}) { + my $method = _method($_, $w == $d ? 1 : 0); + push @methods, $method if + (not $want_recurring or $method->{payment_recurring}) # want_recurring -> payment_recurring + and + (not $want_used or $method->{payment_used}); # want_used -> payment_used + } + } + + for (@methods) { $_->{payment_direct} ? $used_direct++ : $used_remote++ if $_->{payment_used} } + + return { + payment_methods => \@methods, + direct_methods => scalar keys %{$d->{methods}}, + direct_methods_used => $used_direct, + direct_methods_unused => keys(%{$d->{methods}}) - $used_direct, + remote_methods => scalar keys %{$r->{methods}}, + remote_methods_used => $used_remote, + remote_methods_unused => keys(%{$r->{methods}}) - $used_remote + }; +} +END_OF_SUB + +$COMPILE{_method} = __LINE__ . <<'END_OF_SUB'; +sub _method { +# ----------------------------------------------------------------------------- +# Takes two arguments - the first is the payment scheme (AuthorizeDotNet, +# PayPal, etc.) and the second is a boolean indicating whether you are looking +# for a "direct" payment method - true means direct, false means remote. +# + my ($method_name, $direct) = @_; + my $p = $CFG->{payment}->{$direct ? 'direct' : 'remote'}; + return unless exists $p->{methods}->{$method_name}; + my $method = { + payment_types => [@{$p->{methods}->{$method_name}->{types}}], + payment_module => $p->{methods}->{$method_name}->{module}, + payment_package => $p->{methods}->{$method_name}->{package}, + payment_recurring => $p->{methods}->{$method_name}->{recurring} + }; + if ($direct) { + $method->{payment_direct} = 1; + $method->{_lang_prefix} = 'DIRECT'; + } + else { + $method->{payment_direct} = 0; + $method->{_lang_prefix} = 'REMOTE'; + } + + $method->{payment_method} = $method_name; + $method->{payment_name} = Links::language("PAYMENT_$method->{_lang_prefix}_$method_name"); + $method->{payment_description} = Links::language("PAYMENT_$method->{_lang_prefix}_${method_name}_description"); + for (@{$method->{payment_types}}) { + $_ = { + code => $_, + name => Links::language("PAYMENT_TYPE_$_") + }; + } + + if (Links::language("PAYMENT_$method->{_lang_prefix}_${method_name}_notes")) { + $method->{payment_notes} = Links::language("PAYMENT_$method->{_lang_prefix}_${method_name}_notes"); + } + + if (Links::language("PAYMENT_URL_$method->{_lang_prefix}_$method_name")) { + $method->{payment_url} = Links::language("PAYMENT_URL_$method->{_lang_prefix}_$method_name"); + } + + my $used = exists $CFG->{payment}->{$method->{payment_direct} ? 'direct' : 'remote'}->{used}->{$method_name}; + $method->{payment_used} = $used ? 1 : 0; + delete $method->{_lang_prefix}; + $method; +} +END_OF_SUB + +$COMPILE{add_method} = __LINE__ . <<'END_OF_SUB'; +sub add_method { +# ----------------------------------------------------------------------------- +# + my $method = $IN->param('method'); + my $type = $IN->param('type'); + my ($d, $r) = @{$CFG->{payment}}{'direct', 'remote'}; + + if ($type eq 'direct') { + if (not exists $d->{methods}->{$method}) { return { method_invalid => 1 } } + } + elsif ($type eq 'remote') { + if (not exists $r->{methods}->{$method}) { return { method_invalid => 1 } } + } + else { return { method_invalid => 1 } } + + my $p = _method($method, $type eq 'direct'); + my $modifying = $IN->param('modify'); + + if (!$p) { + return { method_invalid => 1 }; + } + elsif ($p->{payment_used} and not $modifying) { + return { method_used => 1 }; + } + + eval { require $p->{payment_module} }; + if ($@) { + my $reason = $@; + $reason =~ s/\n/
        \n/g; + return { method_failed => 1, method_failed_reason => \$reason }; + } + my $pkg = $p->{payment_package}; + + my $ret = { %$p }; + + my @required = $pkg->required(); + my @optional = $pkg->optional(); + + my $lang_prefix = 'PAYMENT_' . ($type eq 'direct' ? 'DIRECT_' : 'REMOTE_'); + for my $f (\@required, \@optional) { + for (my $i = 0; $i < @$f; $i += 2) { + my ($field, $spec) = @$f[$i, $i + 1]; + + my $opt = { + %$spec, + field => $field, + field_title => Links::language("$lang_prefix${method}_$field"), + field_description => Links::language("$lang_prefix${method}_${field}_description"), + }; + if ($modifying and exists $CFG->{payment}->{$type}->{used}->{$method}->{$field}) { + $opt->{field_value} = $CFG->{payment}->{$type}->{used}->{$method}->{$field}; + } + + delete $opt->{options}; + if (ref $spec->{options} eq 'ARRAY') { + for (my $o = 0; $o < @{$spec->{options}}; $o += 2) { + push @{$opt->{options}}, { value => $spec->{options}->[$o], string => $spec->{options}->[$o + 1] }; + } + } + + push @{$ret->{$f == \@required ? 'required_fields' : 'optional_fields'}}, $opt; + } + } + + return $ret; +} +END_OF_SUB + + +$COMPILE{add_method_submit} = __LINE__ . <<'END_OF_SUB'; +sub add_method_submit { +# ----------------------------------------------------------------------------- +# Tasks to perform here: Check that all required fields are set, and make sure +# they have valid values. Check that any optional fields set have valid values. +# If it all checks out, save it in $CFG->{payment}. +# + + my $type = $IN->param('type'); + my $method_name = $IN->param('method'); + my $method = _method($method_name, $type eq 'direct'); + if (!$method) { + return { + method_success => undef, + method_invalid => 1 + }; + } + elsif ($method->{payment_used} and not $IN->param('modify')) { + return { + method_success => undef, + method_used => 1 + }; + } + + eval { require $method->{payment_module} }; + if ($@) { + my $reason = $@; + $reason =~ s/\n/
        \n/g; + return { + method_success => undef, + method_failed => 1, + method_failed_reason => \$reason + }; + } + my $pkg = $method->{payment_package}; + + my @required = $pkg->required(); + my @optional = $pkg->optional(); + + my (%settings, %missing, %opt_invalid); + for (my $i = 0; $i < @required; $i += 2) { + my $val = $IN->param($required[$i]); + my $langed = Links::language('PAYMENT_' . ($type eq 'direct' ? 'DIRECT' : 'REMOTE') . "_${method_name}_$required[$i]"); + my $info = $required[$i + 1]; + if ($info->{type} eq 'SELECT' or $info->{type} eq 'RADIO') { + my $good; + for (my $i = 0; $i < @{$info->{options}}; $i += 2) { + if ($val eq $info->{options}->[$i]) { + $good = 1; + last; + } + } + if (!$good) { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_NONE') => $langed; + } + elsif ($val eq 'custom' and $info->{custom}) { + my $custom_val = $IN->param("$required[$i]_custom"); + if ($info->{valid} and $custom_val !~ /$info->{valid}/) { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_INVALID') => $langed, $custom_val; + } + elsif ($custom_val !~ /\S/) { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_NONE') => $langed; + } + + $settings{"$required[$i]_custom"} = $custom_val unless $missing{$required[$i]}; + } + } + elsif ($info->{type} eq 'YESNO') { + if (defined $val and $val eq '1' || $val eq '0') { + $val = $val ? 1 : 0; + } + else { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_NONE') => $langed; + } + } + else { + if ($info->{valid}) { + if ($val !~ /$info->{valid}/) { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_INVALID') => $langed, $val; + } + } + elsif ($val !~ /\S/) { + $missing{$required[$i]} = sprintf Links::language('PAYMENT_ADD_NONE') => $langed; + } + } + $settings{$required[$i]} = $val unless exists $missing{$required[$i]}; + } + + for (my $i = 0; $i < @optional; $i += 2) { + my $val = $IN->param($optional[$i]); + defined($val) and $val =~ /\S/ or next; + my $langed = Links::language('PAYMENT_' . ($type eq 'direct' ? 'DIRECT' : 'REMOTE') . "_${method_name}_$optional[$i]"); + my $info = $optional[$i + 1]; + if ($info->{type} eq 'SELECT' or $info->{type} eq 'RADIO') { + my $good; + for (my $i = 0; $i < @{$info->{options}}; $i += 2) { + if ($val eq $info->{options}->[$i]) { + $good = 1; + last; + } + } + unless ($good) { + $opt_invalid{$optional[$i]} = sprintf Links::language('PAYMENT_ADD_OPT_INVALID') => $langed; + } + } + elsif ($info->{type} eq 'YESNO') { + $val = $val ? 1 : 0; + } + else { + if ($info->{valid}) { + if ($val !~ /$info->{valid}/) { + $opt_invalid{$optional[$i]} = sprintf Links::language('PAYMENT_ADD_INVALID') => $langed, $val; + } + } + } + $settings{$optional[$i]} = $val unless exists $opt_invalid{$optional[$i]}; + } + + if (keys %opt_invalid or keys %missing) { + my $ret = { %{add_method()} }; + $ret->{method_success} = undef; + $ret->{method_insufficient} = \join '
        ', values %missing, values %opt_invalid; + for (@{$ret->{required_fields}}) { + if (exists $missing{$_->{field}}) { + $_->{missing} = 1; + } + $_->{field_value} = $IN->param($_->{field}); + } + for (@{$ret->{optional_fields}}) { + if (exists $opt_invalid{$_->{field}}) { + $_->{invalid} = 1; + } + $_->{field_value} = $IN->param($_->{field}); + } + return $ret; + } + + $CFG->{payment}->{$type eq 'direct' ? 'direct' : 'remote'}->{used}->{$method_name} = \%settings; + + $CFG->save(); + + return { %$method, method_success => 1 }; +} +END_OF_SUB + +$COMPILE{remove_method} = __LINE__ . <<'END_OF_SUB'; +sub remove_method { +# ----------------------------------------------------------------------------- +# + my $method = $IN->param('method'); + my $type = $IN->param('type'); + + return { method_invalid => 1 } if + $type ne 'direct' and $type ne 'remote' or + not exists $CFG->{payment}->{$type eq 'direct' ? 'direct' : 'remote'}->{methods}->{$method}; + return { method_not_used => 1 } + if not exists $CFG->{payment}->{$type eq 'direct' ? 'direct' : 'remote'}->{used}->{$method}; + + my $p = _method($method, $type eq 'direct'); + + if (!$p) { + return { method_invalid => 1 }; + } + elsif (not $p->{payment_used}) { + return { method_not_used => 1 }; + } + + + if ($IN->param('confirm')) { + my %ret = (method_removed => 1); + delete $CFG->{payment}->{$type}->{used}->{$method}; + + if ($CFG->{payment}->{enabled} and + !keys %{$CFG->{payment}->{remote}->{used}} and + !keys %{$CFG->{payment}->{direct}->{used}}) { + $ret{no_methods_left}++; + } + + $CFG->save(); + return \%ret; + } + else { + return $p; + } +} +END_OF_SUB + +$COMPILE{recurring_enabled} = __LINE__ . <<'END_OF_SUB'; +sub recurring_enabled { +# ----------------------------------------------------------------------------- +# Returns whether or not recurring payments can be accepted. +# +# There are two requirements: +# - Recurring term must be defined for a particular category in Database section +# - A payment method supporting recurring payments must be configured. +# + my $recurring_method; +# Look for an enabled method which supports recurring payments + for my $which (qw/remote direct/) { + for my $meth (keys %{$CFG->{payment}->{$which}->{used}}) { + if ($CFG->{payment}->{$which}->{methods}->{$meth}->{recurring}) { + $recurring_method = 1; + last; + } + } + } + my $recurring; + if (exists $CFG->{payment}->{term}->{types}->{recurring} and keys %{$CFG->{payment}->{term}->{types}->{recurring}}) { + $recurring = 1; + } + + return $recurring && $recurring_method; +} +END_OF_SUB + + +$COMPILE{log_counts} = __LINE__ . <<'END_OF_SUB'; +sub log_counts { +# ----------------------------------------------------------------------------- +# Returns a number of template variables related to the number of entries in +# the payment logs. +# + my $PaymentLog = $DB->table('PaymentLogs'); + $PaymentLog->select_options('GROUP BY paylogs_viewed, paylogs_type'); + my $sth = $PaymentLog->select('paylogs_viewed', 'paylogs_type', 'COUNT(*)'); + + my %map = ( # Using ',' instead of '=>' because these are constants, not strings + LOG_ACCEPTED, 'num_successful', + LOG_DECLINED, 'num_declined', + LOG_INFO, 'num_info', + LOG_ERROR, 'num_error', + LOG_MANUAL, 'num_manual' + ); + + my $ret; + while (my ($viewed, $type, $count) = $sth->fetchrow) { + next unless exists $map{$type}; + $ret->{$viewed ? $map{$type} : "$map{$type}_unviewed"} = $count; + } + return $ret; +} +END_OF_SUB + +$COMPILE{view_log} = __LINE__ . <<'END_OF_SUB'; +sub view_log { +# ----------------------------------------------------------------------------- +# + my $log_type = shift; + my $tables = $DB->table('PaymentLogs', 'Payments', 'Links'); + + my ($limit, $offset, $page) = Links::limit_offset(scalar $IN->param('mh'), scalar $IN->param('pg'), 50); + + my $count = $tables->count({ paylogs_type => $log_type }); + + $tables->select_options("ORDER BY paylogs_time DESC", "LIMIT $limit OFFSET $offset"); + my $results = $tables->select(defined $log_type ? ({ paylogs_type => $log_type }) : ())->fetchall_hashref; + my @viewing = map $_->{paylogs_id}, @$results; + + $DB->table('PaymentLogs')->update({ paylogs_viewed => 1 }, { paylogs_id => \@viewing }); + return { db_prefix => $DB->prefix, log_type => $log_type, logs => $results, num_logs => $count, page => $page, mh => $limit }; +} +END_OF_SUB + +$COMPILE{delete_log} = __LINE__ . <<'END_OF_SUB'; +sub delete_log { +# ----------------------------------------------------------------------------- +# + + my $id = shift; + my %ret; + if ($id =~ /\D/) { + $ret{error} = Links::language('PAYLOG_INVALID_ID'); + } + else { + my $logs = $DB->table('PaymentLogs'); + my $deleted = $logs->delete({ paylogs_id => $id }); + if ($deleted > 0) { + $ret{message} = Links::language('PAYLOG_DEL_SUCCESS'); + } + else { + $ret{error} = Links::language('PAYLOG_INVALID_ID'); + } + } + return \%ret; +} +END_OF_SUB + +$COMPILE{view_details} = __LINE__ . <<'END_OF_SUB'; +sub view_details { + my $payment_id = shift; + my $payment = $DB->table('Payments' => 'Links')->select({ payments_id => $payment_id })->fetchrow_hashref; + $payment or return; + + my ($type, $method) = $payment->{payments_method} =~ /^(direct|remote)_(\w+)$/; + $payment->{payments_direct} = 1 if $type eq 'direct'; + $payment->{payments_remote} = 1 if $type eq 'remote'; + $payment->{payments_method} = $method if $method; + + if (my ($num, $unit) = $payment->{payments_term} =~ /^(\d+)([dwmy])$/) { + $payment->{payments_term_num} = $num; + $payment->{payments_term_unit} = Links::language($Lang_map{$unit} . ($num == 1 ? '' : 'S')); + } + + unless ($payment->{payments_method} eq 'trial') { + $payment->{payments_method} = Links::language(($payment->{payments_direct} ? 'PAYMENT_DIRECT_' : 'PAYMENT_REMOTE_') . $payment->{payments_method}); + } + + my $pl = $DB->table('PaymentLogs'); + $pl->select_options('ORDER BY paylogs_time DESC'); + my $logs = $pl->select({ paylogs_payments_id => $payment->{payments_id} })->fetchall_hashref; + + for (@$logs) { + $_->{paylogs_text} =~ s/\n/
        \n/g; + } + + return { + %$payment, + logs => $logs, + db_prefix => $pl->{connect}->{PREFIX} + }; +} +END_OF_SUB + +sub process_payment { +# ----------------------------------------------------------------------------- +# Processes a signup/renewal/recurring payment. Takes the link ID, payment +# term (such as "3d", "1m", "6w", "2y"), and optionally an extra +# true variable that adds a day to the payment time (to cover delays in the +# recurring post). Typically this extra day is for the initial payment in a +# series of recurring payments, and is _not_ applied for the remaining +# recurring payments. + my ($link_id, $term, $extra_day) = @_; + my $expiry; + if ($term eq 'unlimited') { + $expiry = UNLIMITED; + } + else { + my ($signup_num, $signup_unit) = $term =~ /^(\d+)([dwmy])(?:-rec)?$/; + + $expiry = $DB->table('Links')->select(ExpiryDate => { ID => $link_id })->fetchrow; + + $extra_day = 0 if $expiry >= time + 24 * 60 * 60; # Don't give an extra day if there is already >1 day of time left + + my @lt = localtime(($expiry > time and $expiry < UNLIMITED) ? $expiry : time); + if ($signup_unit eq 'w') { $lt[3] += $signup_num * 7 } + elsif ($signup_unit eq 'm') { $lt[4] += $signup_num } # This can be weird; Jan 31st + 1 month = Mar 3rd, but Feb 1st + 1 month = Mar 1st + elsif ($signup_unit eq 'y') { $lt[5] = ($lt[5] + $signup_num <= 137 ? $lt[5] + $signup_num : 137) } # 137 is 2037 - 2038 introduces 32-bit date problems. + else { $lt[3] += $signup_num } # Assume days + + # This must be GT::Date's timelocal() - Time::Local doesn't allow something + # like Feb 31th (Jan 31th + 1 month). GT::Date::timelocal() treats it as + # Mar. 3rd (or 2nd in a leap year). + $expiry = timelocal(@lt); + $expiry += 24 * 60 * 60 if $extra_day; + } + +# Get the link and prepare some default values + my $link = $DB->table('Links')->get($link_id); + $link->{'CatLinks.CategoryID'} = $IN->param('cat_id'); + $link->{'CatLinks.CategoryID'} ||= $DB->table('CatLinks')->select(CategoryID => { LinkID => $link_id })->fetchrow; # postback processing + $link->{ExpiryDate} = $expiry; + $link->{ExpiryNotify} = 0; + +# Validate the link if payment auto-validation or manually aproved by admin + $CFG->{payment}->{auto_validate} and $link->{isValidated} = 'Yes'; + my $payment = $DB->table('Payments')->select({ + payments_linkid => $link_id, + payments_status => COMPLETED + })->fetchrow_hashref; + $payment->{payments_method} eq 'remote_Manual' and $link->{isValidated} = 'Yes'; + +# Update the link + $DB->table('Links')->modify($link); + +# Make sure the ExpiryDate isn't overwritten by the one in the Changes table + my $changes = $DB->table('Changes'); + my $change = $changes->select('ChgRequest', { LinkID => $link_id })->fetchrow; + if ($change) { + $change = eval $change; + if (exists $change->{ExpiryDate}) { + $change->{ExpiryDate} = $expiry; + require GT::Dumper; + $changes->update({ ChgRequest => GT::Dumper->dump({ data => $change, var => '' }) }, { LinkID => $link_id }); + } + } + +# Send notification email + my ($type, $method) = $payment->{payments_method} =~ /^(direct|remote)_(\w+)$/; + $link->{Category} = $DB->table('Category', 'CatLinks')->select('Category.Full_Name' => { 'CatLinks.LinkID' => $link->{ID} })->fetchrow; + if ($CFG->{admin_email_add}) { + Links::send_email('link_added.eml', $link, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + if ($CFG->{email_payment} and $link->{isValidated} eq 'Yes') { + Links::send_email('payment_received.eml', $link) or die "Unable to send mail: $GT::Mail::error"; + } + return $expiry; +} + +sub admin_approve_payment { +# ----------------------------------------------------------------------------- +# This subroutine is called from the admin payment details page giving you the +# ability to manually approve a payment. +# + my $payment_id = shift; + + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + + my $payment = $pay->select({ payments_id => $payment_id })->fetchrow_hashref; + $payment and $payment->{payments_status} != COMPLETED or return; + $pay->update( + { payments_status => COMPLETED, payments_last => time }, + { payments_id => $payment->{payments_id} } + ); + + $log->delete({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_MANUAL + }); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_ACCEPTED, + paylogs_time => time, + paylogs_text => Links::language('PAYMENT_MANUAL') || 'Payment manually approved' + }); + + process_payment($payment->{payments_linkid}, $payment->{payments_term}); + + return { manual_payment_success => 1 }; +} + +$COMPILE{postback} = __LINE__ . <<'END_OF_SUB'; +sub postback { +# ----------------------------------------------------------------------------- +# + shift if UNIVERSAL::isa($_[0], __PACKAGE__); + my $postback = shift or return; + my $type = $postback->{method_type} || 'remote'; + my $meth = $postback->{method} or return; + return unless exists $CFG->{payment}->{$type}->{used}->{$meth}; + + my $method = _method($meth, $type eq 'direct') or return; + + require $method->{payment_module}; + my $pkg = $method->{payment_package}; + + $pkg->postback(); +} +END_OF_SUB + +$COMPILE{invalid_postback} = __LINE__ . <<'END_OF_SUB'; +sub invalid_postback { +# ----------------------------------------------------------------------------- +# + shift if UNIVERSAL::isa($_[0], __PACKAGE__); + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + my $unique = $IN->param('invoice') || $IN->param('cartId') || $IN->param('cart_order_id'); + my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref or return; + my $text = "Invalid postback: \n"; + $text .= join "\n" => map "$_: ".$IN->get_hash->{$_} => keys %{$IN->get_hash}; + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_INFO, + paylogs_time => time, + paylogs_text => $text + }); +} +END_OF_SUB + +sub error { +# ----------------------------------------------------------------------------- +# Override Links::error(), this hacks around not being able to easily specify +# what template to send the user to and to pass template variables to that page. +# This was really only designed to be used in the method(), form(), and +# direct() subs. +# + my ($self, $msg, $sev, $vars, @args) = @_; + $msg ||= ''; + $sev ||= 'FATAL'; + if (uc $sev eq 'FATAL') { + return $self->SUPER::error($msg, $sev, @args); + } + + my %valid_subs = ( + 'method' => 1, + 'form' => 1, + 'direct' => 1 + ); + + my @ret; + push @ret, $vars if $vars; + if (my $method = $IN->delete('last_step')) { + if (exists $valid_subs{$method}) { + push @ret, $self->$method(); + } + } + my $error = $msg; + $error = Links::language($msg); + + if ($error) { + $error = sprintf($error, map { ref($_) ? () : defined($_) ? $_ : '' } @args) if @args and index($error, '%') >= 0; + push @ret, { error => $error }; + } + + if ($IN->param('last_page')) { + $IN->param(page => scalar $IN->param('last_page')); + } + return { map { %$_ } @ret }; +} + +sub expiry { +#------------------------------------------------------------------------------ +# Sending email to links that are about to reach the expiry date. +# + my $days = shift || 7; + + return unless $CFG->{payment}->{enabled}; + +# required modules + require GT::Date; + require GT::SQL::Condition; + + my $notify = time + $days * 24 * 60 * 60; + my $users_links = $DB->table('Users', 'Links'); + my $payments = $DB->table('Payments'); + + my (%users, %links, %exp_users, %exp_links); + my $date_format = $CFG->{date_user_format} || '%dddd% %mmm% %dd% %yyyy%'; + +# Load links that are about to expire + $users_links->select_options('ORDER BY Username'); + my $links = $users_links->select( + 'Username', 'Email', 'Name', 'ID', 'Title', 'ExpiryDate', + GT::SQL::Condition->new( + ExpiryDate => '>=' => time, + ExpiryDate => '<=' => $notify, + ExpiryNotify => '=' => 0 + ) + ) or die $GT::SQL::error; + while (my ($user, $email, $name, $id, $title, $expiry) = $links->fetchrow) { + $payments->select_options("ORDER BY payments_last DESC", "LIMIT 1"); + my $last_payment_type = $payments->select(payments_type => { + payments_linkid => $id, + payments_status => COMPLETED + })->fetchrow; + next if $last_payment_type == RECURRING; + + $users{$user} ||= [$email, $name]; + $links{$user} ||= []; + push @{$links{$user}}, { + ID => $id, + Title => $title, + ExpiryDate => GT::Date::date_get($expiry, $date_format), + renewal_url => "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$id" + }; + } + my $count = 0; + + if (%links) { + $count += expiry_process('notify', \%links, \%users); + } + +# Load links that have already expired + $users_links->select_options('ORDER BY Username'); + my $exp_links = $users_links->select( + 'Username', 'Email', 'Name', 'ID', 'Title', 'ExpiryDate', + GT::SQL::Condition->new( + ExpiryDate => '<' => time, + ExpiryDate => '>' => UNPAID, + ExpiryNotify => '<' => 2 + ) + ) or die $GT::SQL::error; + while (my ($user, $email, $name, $id, $title, $expiry) = $exp_links->fetchrow) { + $exp_users{$user} ||= [$email, $name]; + $exp_links{$user} ||= []; + push @{$exp_links{$user}}, { + ID => $id, + Title => $title, + ExpiryDate => GT::Date::date_get($expiry, $date_format), + renewal_url=> "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$id" + }; + } + + if (%exp_links) { + $count += expiry_process('expired', \%exp_links, \%exp_users); + } + print "$count email(s) were sent.\n"; +} + +sub expiry_process { + my ($type, $links, $users) = @_; + + my $db_link = $DB->table('Links'); + my $email = ($type eq 'expired') ? 'link_expired.eml' : 'link_expiry_notify.eml'; + my $notified = ($type eq 'expired') ? 2 : 1; + my $count; + foreach my $u (keys %$users) { + my $lks = $links->{$u}; + next if ($#$lks == -1); + + my @ids = map $_->{ID}, @{$lks}; + if (Links::send_email($email, { Name => $users->{$u}->[1], Email => $users->{$u}->[0], expiry_links => $lks })) { + $db_link->update({ ExpiryNotify => $notified }, GT::SQL::Condition->new(ID => 'IN' => \@ids)); + $count++; + } + else { + warn "Unable to send mail: $GT::Mail::error"; + } + } + return $count; +} + +sub currency { +# ----------------------------------------------------------------------------- +# + \sprintf Links::language('PAYMENT_CURRENCY_FORMAT') => @_; +} + +sub next_years { +# ----------------------------------------------------------------------------- +# Returns the next x years, in template loop variable "next_years". +# + shift; + my $years = shift; + + $years = 10 if !$years or $years < 1; + my $year = (localtime)[5] + 1900; + return { + next_years => [$year .. $year + $years] + }; +} + +sub generate_unique_id { +# ----------------------------------------------------------------------------- +# + require GT::MD5; + my $id; + do { + $id = substr(GT::MD5::md5_hex(time . $$ . rand(16000)), 0, 16) + } while $DB->table('Payments')->count(payments_id => $id) > 0; + + return $id; +} + +sub convert_to_days { +# ----------------------------------------------------------------------------- +# Given a payment_term time interval, this returns the equivalent number of days. +# + my $date = shift; + + if ($date and $date =~ /^(\d+)([dwmy])$/) { + return $1 * $Ptd{$2}; + } + return 0x7fff_ffff; +} + +sub check_discount { +# ----------------------------------------------------------------------------- +# This returns the number of discount percent for current user. +# + return unless $USER; + + my $id = $IN->param('ID') || $IN->param('link_id'); + +# Skip discount if renewal payment + if ($id and $id =~ /^\d+$/) { + my $link = $DB->table('Links')->get($id); + return if ($link->{ExpiryDate} > 0 and $link->{ExpiryDate} < UNLIMITED); + } + my $link_count = $DB->table('Links')->count( + GT::SQL::Condition->new( + LinkOwner => '=' => $USER->{Username}, + ExpiryDate => '>=' => time, + ExpiryDate => '<' => FREE + ) + ); + my $discount; + foreach my $num (sort { $a <=> $b } keys %{$CFG->{payment}->{discounts}}) { + ($link_count < $num - 1) and last; + $discount = $CFG->{payment}->{discounts}->{$num}; + } + return $discount; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/AuthorizeDotNet.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/AuthorizeDotNet.pm new file mode 100644 index 0000000..28fe168 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/AuthorizeDotNet.pm @@ -0,0 +1,165 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: AuthorizeDotNet.pm,v 1.3 2005/03/05 01:29:09 brewt 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. +# ================================================================== +# +# Glue between Gossamer Links and Authorize.Net payment interface + +package Links::Payment::Direct::AuthorizeDotNet; +use strict; + +# Make sure the payment module is available +use GT::Payment::Direct::AuthorizeDotNet; +use Links qw/$IN $CFG $DB/; +use vars qw/%INVALID %EMPTY/; + +sub required { +# ----------------------------------------------------------------------------- +# Returns a list of required field names. Each field name will be looked for +# in the language file, prefixed with 'PAYMENT_DIRECT_AuthorizeDotNet_', for +# the title of the field, and 'PAYMENT_DIRECT_DESC_AuthorizeDotNet_' for a +# description of the field's contents. +# Note that these are just required SETUP fields, so things like credit card +# number, billing name, etc. are NOT included. + return + account_username => { type => 'TEXT', valid => '^\w+$' }, # FIXME - I have no idea what this can be + account_key => { type => 'TEXT', valid => '^\w+$' }; + +} + +sub optional { +# ----------------------------------------------------------------------------- + my @currencies; + for (sort { + $a eq 'USD' ? -1 : $b eq 'USD' ? 1 : $a eq 'CAD' ? -1 : $b eq 'CAD' ? 1 : + $GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$a} cmp + $GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$b} + } keys %GT::Payment::Direct::AuthorizeDotNet::CURRENCY) { + push @currencies, $_ => $GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$_}; + } + return + currency => { + type => 'SELECT', + options => \@currencies + }, + account_password => { type => 'TEXT', size => 40, valid => '.' }, # An optionally-required account password + confirmation_merchant => { type => 'TEXT', size => 40, valid => '.@.' }, # A merchant confirmation e-mail address + confirmation_confirm => { type => 'YESNO' }, # Whether or not to send a customer confirmation e-mail. + test_mode => { type => 'YESNO' } +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hash of various parameters used to figure out how to display the +# payment form for this payment method. + return { + no_cc_brand => 1, + fields => [ + grep ! /^(?:account|capture|currency|test)/, keys %GT::Payment::Direct::AuthorizeDotNet::VALID + ], + billing_phone_required => 1 + } +} + +sub verify { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns 1 on success, or an array ref of invalid keys +# on failure. + _collect_data(); + if (keys %INVALID or keys %EMPTY) { + my ($i, %order); + for (@{$GT::Payment::Direct::AuthorizeDotNet::REQUIRED{AUTHORIZE}}) { $order{$_} = $i++ } + return [ # Error + [sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %INVALID], + [sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %EMPTY] + ]; + } + else { + return 1; # Success + } +} + +sub complete { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns (1, $message) on success, (0, $reason) on +# declined, or (-1, $errormsg) on error. + + my $pay = _collect_data() or return; + +# Set the admin-specified fields + while (my ($k, $v) = each %{$CFG->{payment}->{direct}->{used}->{AuthorizeDotNet}}) { + $pay->$k($v) or return (-1, "Payment configuration error (Invalid $k)"); + } + + $pay->check('sale') or return (-1, $pay->error); + my $ret = $pay->sale; + if (not defined $ret) { # An error occured in the module + return (-1, $pay->error); + } + else { # The request at least got through to Authorize.Net + my $response = $pay->response; + if ($ret == 1) { # Approved! + my @receipt = @{$response->{receipt}}; + + my $receipt = "Transaction approved\n\n"; + while (@receipt) { + my ($k, $v) = splice @receipt, 0, 2; + $receipt .= "$k: $v\n"; + } + + return (1, $response->{reason_text}, $receipt); + } + elsif ($ret == 0) { # Declined + return (0, $response->{reason_text}); + } + else { # An error was generated by Authorize.Net + return (-1, $response->{reason_text}); + } + } +} + +sub _collect_data { +# ----------------------------------------------------------------------------- +# Collect data from the payment data saved in the admin, and any valid columns +# in $IN. Anything from $IN is checked for validity, and $INVALID{column} is +# set if invalid. + %INVALID = %EMPTY = (); + return unless $CFG->{payment}->{direct}->{used}->{AuthorizeDotNet}; + my %data = %{$CFG->{payment}->{direct}->{used}->{AuthorizeDotNet}}; + my $pay = GT::Payment::Direct::AuthorizeDotNet->new(); + my %required = map { $_ => 1 } @{$GT::Payment::Direct::AuthorizeDotNet::REQUIRED{AUTHORIZE}}; + for my $field (keys %GT::Payment::Direct::AuthorizeDotNet::VALID) { + # The account_*, capture_*, currency_*, etc. fields should not be user-settable. + next if exists $data{$field} or $field =~ /^(?:account|capture|currency|test)/; + if (my $value = $IN->param($field)) { + if ($pay->$field($value)) { + $data{$field} = $value; + } + else { + $INVALID{$field}++; + $data{$field} = undef; + } + } + elsif ($required{$field}) { + $EMPTY{$field}++; + $data{$field} = undef; + } + } + + $pay->billing_ip($ENV{REMOTE_ADDR}) if $ENV{REMOTE_ADDR} and $ENV{REMOTE_ADDR} ne '127.0.0.1'; + + return if keys %INVALID or keys %EMPTY; + return $pay; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/Moneris.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/Moneris.pm new file mode 100644 index 0000000..96cdccb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Direct/Moneris.pm @@ -0,0 +1,152 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Moneris.pm,v 1.2 2005/03/05 01:29:09 brewt 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. +# ================================================================== +# +# Glue between Gossamer Links and Moneris payment interface + +package Links::Payment::Direct::Moneris; +use strict; + +# Make sure the payment module is available +use GT::Payment::Direct::Moneris 1.007; # CVS Versions < 1.7 were for the old, defunct Moneris payment system +use Links qw/$IN $CFG $DB/; +use vars qw/%INVALID %EMPTY/; + +my @FIELDS = ( + keys %GT::Payment::Direct::Moneris::NAME_MAP, + qw/ credit_card_number credit_card_expiry_month credit_card_expiry_year + billing_country billing_email charge_total/ +); + +sub required { +# ----------------------------------------------------------------------------- +# Returns a list of required field names. Each field name will be looked for +# in the language file, prefixed with 'PAYMENT_DIRECT_Moneris_', for the title +# of the field, and 'PAYMENT_DIRECT_DESC_Moneris_' for a description of the +# field's contents. +# Note that these are just required SETUP fields, so things like credit card +# number, billing name, etc. are NOT included. + return + account_token => { type => 'TEXT', valid => '^\w+$' }, + account_token2 => { type => 'TEXT', valid => '^\w+$' }; +} + +sub optional { + return + test_mode => { type => 'YESNO' } +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hash of various parameters used to figure out how to display the +# payment form for this payment method. + return { + fields => [ + grep ! /^(?:account|capture|currency|test)/, @FIELDS + ], + no_cc_brand => 1 + }; +} + +sub verify { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns 1 on success, or an array ref of invalid and +# empty keys array references (i.e. [\@invalid, \@empty]) on failure. + _collect_data(); + if (keys %INVALID or keys %EMPTY) { + my ($i, %order); + for (@{$GT::Payment::Direct::Moneris::REQUIRED{AUTHORIZE}}) { $order{$_} = $i++ } + return [ # Error + [sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %INVALID], + [sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %EMPTY] + ]; + } + else { + return 1; # Success + } +} + +sub complete { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns (1, $message) on success, (0, $reason) on +# declined, or (-1, $errormsg) on error. + + my $pay = _collect_data() or return; + +# Set the admin-specified fields + while (my ($k, $v) = each %{$CFG->{payment}->{direct}->{used}->{Moneris}}) { + $pay->$k($v) or return (-1, "Payment configuration error (Invalid $k)"); + } + + $pay->check('sale') or return (-1, $pay->error); + my $ret = $pay->sale; + if (not defined $ret) { # An error occured in the module + return (-1, $pay->error); + } + else { # The request at least got through to Moneris + if ($ret == 1) { # Approved! + my $resp_text; + my @receipt = $pay->receipt(); + my $receipt = "Transaction approved\n\n"; + while (@receipt) { + my ($k, $v) = splice @receipt, 0, 2; + $receipt .= "$k: $v\n"; + $resp_text = $v if $k eq 'Status'; + } + + return (1, $resp_text, $receipt); + } + elsif ($ret == 0) { # Declined + return (0, $pay->error); + } + else { # An error was generated by Moneris + return (-1, $pay->error); + } + } +} + +sub _collect_data { +# ----------------------------------------------------------------------------- +# Collect data from the payment data saved in the admin, and any valid columns +# in $IN. Anything from $IN is checked for validity, and $INVALID{column} is +# set if invalid. + %INVALID = %EMPTY = (); + return unless $CFG->{payment}->{direct}->{used}->{Moneris}; + my %data = %{$CFG->{payment}->{direct}->{used}->{Moneris}}; + return unless keys %data; + my $pay = GT::Payment::Direct::Moneris->new(debug_level => $CFG->{debug}); + my %required = map { $_ => 1 } @{$GT::Payment::Direct::Moneris::REQUIRED{AUTHORIZE}}; + for my $field (@FIELDS) { + # The account_*, capture_*, currency_*, etc. fields should not be user-settable. + next if exists $data{$field} or $field =~ /^(?:account|capture|currency|test)/; + if (my $value = $IN->param($field)) { + if ($pay->$field($value)) { + $data{$field} = $value; + } + else { + $INVALID{$field}++; + $data{$field} = undef; + } + } + elsif ($required{$field}) { + $EMPTY{$field}++; + $data{$field} = undef; + } + } + + return if keys %INVALID or keys %EMPTY; + return $pay; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/2CheckOut.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/2CheckOut.pm new file mode 100644 index 0000000..2fa7136 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/2CheckOut.pm @@ -0,0 +1,122 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: 2CheckOut.pm,v 1.13 2006/08/22 23:07:53 brewt 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. +# ================================================================== +# +# Glue between Gossamer Links and 2CheckOut payment interface + +package Links::Payment::Remote::2CheckOut; +use strict; + +# Make sure the payment module is available +use GT::Payment::Remote::2CheckOut; +use Links qw/:objects/; +use Links::Payment qw/:status :log/; +use Links::SiteHTML; +use vars qw/%INVALID %EMPTY/; + +sub required { +# ----------------------------------------------------------------------------- +# Returns a list of required field names. Each field name will be looked for +# in the language file, prefixed with 'PAYMENT_REMOTE_2CheckOut_', for the +# title of the field, and 'PAYMENT_REMOTE_DESC_2CheckOut_' for a description of +# the field's contents. +# Note that these are just required SETUP fields, so things like credit card +# number, billing name, etc. are NOT included. + + return + seller_id => { type => 'TEXT', valid => '^\d{1,10}$' }, + secret_word => { type => 'TEXT', valid => '^(?!tango$).+$' }; +} + +sub optional { +# ----------------------------------------------------------------------------- + return + demo => { type => 'YESNO' }; +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hashref of payment hints +# + my @fields = qw/seller_id secret_word demo/; + my $ret = { + fields => \@fields + }; + if (my $info = $CFG->{payment}->{remote}->{used}->{'2CheckOut'}) { + for (@fields) { + $ret->{$_} = $info->{$_}; + } + } + return $ret; +} + +sub verify { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns 1 on success, or an array ref of invalid keys +# on failure. For Remote payment methods, this has no real effect. + return 1; +} + +sub postback { +# ----------------------------------------------------------------------------- + + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + + my $unique = $IN->param('cart_order_id'); + my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref + or return; # Whatever it is, we didn't create it. + + GT::Payment::Remote::2CheckOut::process( + param => $IN, + sellerid => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{seller_id}, + password => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{secret_word}, + demo => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{demo}, + on_valid => sub { + return unless $IN->param('total') >= $payment->{payments_amount}; + + return if $payment->{payments_status} == COMPLETED; + + my $cond = GT::SQL::Condition->new(); + $cond->add(paylogs_payments_id => '=' => $unique); + $cond->add(paylogs_type => '=' => LOG_ACCEPTED); + $cond->add(paylogs_text => LIKE => "%\n2CheckOut order number: " . $IN->param('order_number') . "%\n"); + my $found = $log->count($cond); + return if $found; + + $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 => ( + sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => '2CheckOut') . "\n" . + "2CheckOut order number: " . $IN->param('order_number') . "\n" . + "Amount: $payment->{payments_amount}\n" + ) + }); + + Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}); + } + ); + + print $IN->header; + print Links::SiteHTML::display('payment_success'); + 1; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/Manual.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/Manual.pm new file mode 100644 index 0000000..f37e14e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/Manual.pm @@ -0,0 +1,70 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Manual.pm,v 1.3 2005/03/05 01:46:06 brewt 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. +# ================================================================== +# +# Glue between Gossamer Links and Manual payment interface + +package Links::Payment::Remote::Manual; +use strict; + +# Make sure the payment module is available +use Links qw/:objects/; +use Links::Payment qw/:status :log/; +use Links::SiteHTML; +use vars qw/%INVALID %EMPTY/; + +sub required { +# ----------------------------------------------------------------------------- +# No required parameters available + return; +} + +sub optional { +# ----------------------------------------------------------------------------- +# No optional parameters available. + return; +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hashref of payment hints +# + return; +} + +sub insert_log { +# ----------------------------------------------------------------------------- +# + my $unique = shift; + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref or return; # return if the payment doesn't exist. + return if $payment->{payments_status} == COMPLETED; + my $cond = GT::SQL::Condition->new( + paylogs_payments_id => '=' => $unique, + paylogs_type => '=' => LOG_ACCEPTED + ); + my $found = $log->count($cond); + return if $found; + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_MANUAL, + paylogs_time => time, + paylogs_text => ( + "This payment will be manually approved by admin.\n" . + "Amount: $payment->{payments_amount}\n" + ) + }); + return; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/PayPal.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/PayPal.pm new file mode 100644 index 0000000..3ddf597 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/PayPal.pm @@ -0,0 +1,296 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: PayPal.pm,v 1.16 2006/12/01 00:31:56 brewt 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. +# ================================================================== +# +# Glue between Gossamer Links and PayPal IPN payment interface + +package Links::Payment::Remote::PayPal; +use strict; + +# Make sure the payment module is available +use GT::Payment::Remote::PayPal; +use Links qw/:objects/; +use Links::Payment qw/:status :log/; +use Links::SiteHTML; +use vars qw/%INVALID %EMPTY/; + +sub required { +# ----------------------------------------------------------------------------- +# Returns a list of required field names. Each field name will be looked for +# in the language hash, prefixed with 'PAYMENT_REMOTE_PayPal_', for the title +# of the field, and 'PAYMENT_REMOTE_DESC_PayPal_' for a description of the +# field's contents. +# Note that these are just required SETUP fields, so things like credit card +# number, billing name, etc. are NOT included. + my @currencies; + for (qw/USD CAD AUD EUR GBP JPY NZD CHF HKD SGD SEK DKK PLN NOK HUF CZK/) { + push @currencies, $_ => Links::language('PAYMENT_CURRENCY_' . $_); + } + + my @buttons; + for (qw/23 cc 02 03 01 9 5 6/) { + push @buttons, "x-click-but$_.gif" => qq||; + } + + my $custom = qq|Custom image:
        {payment}->{remote}->{used}->{PayPal} and $CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}) { + $custom .= qq| value="$CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}"|; + } + $custom .= '>'; + + push @buttons, "custom" => $custom; + + return + business_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' }, + currency => { + type => 'SELECT', + options => \@currencies + }, + button => { + type => 'RADIO', + options => \@buttons, + custom => 1, + valid => '^https?://[a-zA-Z0-9-]' # Only applies to the custom value + } +} + +sub optional { +# ----------------------------------------------------------------------------- + return + image_url => { type => 'TEXT', size => 60, value => '^https?://[a-zA-Z0-9-]' }, + notify_url => { type => 'TEXT', size => '60', value => '^https?://[a-zA-Z0-9-]' }, + note => { type => 'TEXT', size => 30, value => '^.{1,30}$' }, + color => { + type => 'SELECT', + options => [ + white => Links::language('PAYMENT_REMOTE_PayPal_color_white'), + black => Links::language('PAYMENT_REMOTE_PayPal_color_black') + ] + }, + to_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' }, + sandbox => { type => 'YESNO' }; +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hash of payment hints +# + my @fields = qw/business_email to_email currency button button_custom image_url notify_url note color sandbox/; + my $ret = { + fields => \@fields + }; + if (my $pp = $CFG->{payment}->{remote}->{used}->{PayPal}) { + for (@fields) { + $ret->{$_ eq 'image_url' ? 'pp_image_url' : $_} = $pp->{$_}; + } + } + return $ret; +} + +sub verify { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns 1 on success, or an array ref of invalid keys +# on failure. + return 1; +} + +sub postback { +# ----------------------------------------------------------------------------- +# Handle PayPal postback + my $unique = $IN->param('invoice'); + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + my $payment = $pay->get($unique) or return; + + GT::Payment::Remote::PayPal::process( + param => $IN, + sandbox => $CFG->{payment}->{remote}->{used}->{PayPal}->{sandbox}, + on_valid => sub { + # If taxes or shipping was added, then mc_gross may be greater than payments_amount. + if ($IN->param('mc_gross') < $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('mc_gross') . " < " . $payment->{payments_amount} + }); + return; + } + elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) { + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_ERROR, + paylogs_time => time, + paylogs_text => "Invalid payment (different currency): " . + $IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency} + }); + return; + } + + return if $payment->{payments_status} == COMPLETED; + + $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 => ( + sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" . + "Transaction ID: " . $IN->param('txn_id') . "\n" . + "Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: " + . $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" . + "Payer Email: " . $IN->param('payer_email') . "\n" + ) + }); + + Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}); + }, + on_pending => sub { + $pay->update({ payments_last => time }, { payments_id => $unique }); + + my $match = Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason')); + my $str = $match ? Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason')) : ''; + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_INFO, + paylogs_time => time, + paylogs_text => ( + "Transaction ID: " . $IN->param('txn_id') . "\n" . + "Pending: " . ($match ? $str : scalar $IN->param('pending_reason')) + ) + }); + }, + on_refund => sub { + $pay->update({ payments_last => time }, { payments_id => $unique }); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_INFO, + paylogs_time => time, + paylogs_text => ( + sprintf(Links::language('PAYMENT_REMOTE_REFUND') => 'PayPal') . "\n" . + "Transaction ID: " . $IN->param('txn_id') . "\n" + ) + }); + }, + on_failed => sub { + $pay->update( + { payments_status => DECLINED, payments_last => time }, + { payments_id => $payment->{payments_id} } + ); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_DECLINED, + paylogs_time => time, + paylogs_text => "Transaction ID: " . $IN->param('txn_id') + }); + }, + on_denied => sub { + $pay->update( + { payments_status => DECLINED, payments_last => time }, + { payments_id => $payment->{payments_id} } + ); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_DECLINED, + paylogs_time => time, + paylogs_text => "Transaction ID: " . $IN->param('txn_id') + }); + }, + duplicate => sub { + my $id = $IN->param('txn_id'); + my $cond = GT::SQL::Condition->new(); + $cond->add(paylogs_payments_id => '=' => $unique); + $cond->add(paylogs_type => '=' => LOG_ACCEPTED); + $cond->add(paylogs_text => LIKE => "%\nTransaction ID: $id\n%"); + my $found = $log->count($cond); + return $found ? undef : 1; # True if everything checks out; undef if a duplicate was found + }, + email => sub { + my $email = shift; + return lc $email eq lc $CFG->{payment}->{remote}->{used}->{PayPal}->{business_email} + }, + on_error => sub { + my $errmsg = shift; + $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('mc_gross') < $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('mc_gross') . " < " . $payment->{payments_amount} + }); + return; + } + elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) { + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_ERROR, + paylogs_time => time, + paylogs_text => "Invalid payment (different currency): " . + $IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency} + }); + 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 => ( + sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" . + "Transaction ID: " . $IN->param('txn_id') . "\n" . + "Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: " + . $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" . + "Payer Email: " . $IN->param('payer_email') . "\n" . + "Subscription ID: " . $IN->param('subscr_id') . "\n" + ) + }); + + Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}, 1); + } + ); + +# There is no way to distinguish between PayPal sending the user back, and +# PayPal posting the IPN, so we print a payment confirmation page. + print $IN->header; + print Links::SiteHTML::display('payment_success'); + 1; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/WorldPay.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/WorldPay.pm new file mode 100644 index 0000000..c8e712a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment/Remote/WorldPay.pm @@ -0,0 +1,207 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: WorldPay.pm,v 1.13 2006/08/22 23:05:13 brewt 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. +# ================================================================== +# +# Glue between Links and WorldPay payment interface + +package Links::Payment::Remote::WorldPay; +use strict; + +# Make sure the payment module is available +use GT::Payment::Remote::WorldPay; +use Links qw/:objects/; +use Links::Payment qw/:status :log/; +use Links::SiteHTML; +use vars qw/%INVALID %EMPTY/; + +sub required { +# ----------------------------------------------------------------------------- +# Returns a list of required field names. Each field name will be looked for +# in the language file, prefixed with 'PAYMENT_REMOTE_WorldPay_', for the title +# of the field, and 'PAYMENT_REMOTE_DESC_WorldPay_' for a description of the +# field's contents. +# Note that these are just required SETUP fields, so things like credit card +# number, billing name, etc. are NOT included. + my @currencies; + for (qw/USD CAD EUR GBP AFA ALL DZD AON ARS AWG AUD BSD BHD BDT BBD BZD BMD BOB BAD BWP BRL BND BGL XOF BIF KHR + XAF CVE KYD CLP CNY COP KMF CRC HRK CUP CYP CZK DKK DJF XCD DOP TPE ECS EGP SVC EEK ETB FKP FJD XPF GMD GHC + GIP GTQ GNF GWP GYD HTG HNL HKD HUF ISK INR IDR IRR IQD ILS JMD JPY JOD KZT KES KRW KPW KWD KGS LAK LVL LBP + LSL LRD LYD LTL MOP MKD MGF MWK MYR MVR MTL MRO MUR MXN MNT MAD MZM MMK NAD NPR ANG NZD NIO NGN NOK OMR PKR + PAB PGK PYG PEN PHP PLN QAR ROL RUR RWF WST STD SAR SCR SLL SGD SKK SIT SBD SOS ZAR LKR SHP SDP SRG SZL SEK + CHF SYP TWD TJR TZS THB TOP TTD TND TRL UGX UAH AED UYU VUV VEB VND YER YUM ZRN ZMK ZWD/) { + push @currencies, $_ => Links::language('PAYMENT_CURRENCY_' . $_); + } + + return + installation_id => { type => 'TEXT', valid => '^\d{1,16}$' }, + callback_password => { type => 'TEXT' }, + md5_password => { type => 'TEXT' }, + currency => { + type => 'SELECT', + options => \@currencies + } +} + +sub optional { +# ----------------------------------------------------------------------------- + return + test_mode => { type => 'SELECT', options => [100 => 'Test mode: Always approved', 101 => 'Test mode: Always declined'] } +} + +sub payment_info { +# ----------------------------------------------------------------------------- +# Returns a hashref of payment hints +# + my @fields = qw/currency installation_id md5_password test_mode/; + my $ret = { + fields => \@fields + }; + if (my $pp = $CFG->{payment}->{remote}->{used}->{WorldPay}) { + for (@fields) { + $ret->{$_ eq 'image_url' ? 'pp_image_url' : $_} = $pp->{$_}; + } + } + return $ret; +} + +sub verify { +# ----------------------------------------------------------------------------- +# Checks that $IN, combined with the saved admin settings, makes up all of the +# required information. Returns 1 on success, or an array ref of invalid keys +# on failure. For Remote payment methods, this has no real effect. + return 1; +} + +sub postback { +# ----------------------------------------------------------------------------- + + my $pay = $DB->table('Payments'); + my $log = $DB->table('PaymentLogs'); + + my $unique = $IN->param('cartId'); + my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref + or return; # Whatever it is, we didn't create it. + + my $end = 1; # Returned after processing - if true, a blank page will be displayed, + # if false, a worldpay receipt page. + + GT::Payment::Remote::WorldPay::process( + param => $IN, + password => $CFG->{payment}->{remote}->{used}->{WorldPay}->{callback_password}, + test_mode => $CFG->{payment}->{remote}->{used}->{WorldPay}->{test_mode}, + on_valid => sub { + # A one-time payment (or the initial payment, in the case of recurring payments) + return unless $IN->param('amount') >= $payment->{payments_amount}; + + return if $payment->{payments_status} == COMPLETED; + + $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 => ( + sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'WorldPay') . "\n" . + "Transaction ID: " . $IN->param('transId') . "\n" . + "Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" . + ($IN->param('futurePayId') ? "FuturePay ID: " . $IN->param('futurePayId') . "\n" : '') . + "Authorization Message: " . $IN->param('rawAuthMessage') . "\n" + ) + }); + + Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}); + + $end = 0; + }, + on_cancel => sub { + # The user clicked "cancel payment" + $pay->update( + { payments_status => DECLINED, payments_last => time }, + { payments_id => $payment->{payments_id} } + ); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_DECLINED, + paylogs_time => time, + paylogs_text => ( + sprintf(Links::language('PAYMENT_REMOTE_CANCELLED') => 'WorldPay') . "\n" . + "Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" + ) + }); + }, + on_invalid_password => sub { + $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 => sprintf(Links::language('PAYMENT_REMOTE_INVALIDPW') => 'WorldPay') . "\n" + }); + }, + on_recurring => sub { + # A recurring payment, NOT counting the original payment + $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 => ( + sprintf(Links::language('PAYMENT_REMOTE_RECURRING_ACCEPTED') => 'WorldPay') . "\n" . + "Transaction ID: " . $IN->param('transId') . "\n" . + "Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" . + "FuturePay ID: " . $IN->param('futurePayId') . "\n" . + "Authorization Message: " . $IN->param('rawAuthMessage') . "\n" + ) + }); + + # The "1" gives them an extra day for recurring payments. + Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}, 1); + }, + on_recurring_failed => sub { + $pay->update( + { payments_status => DECLINED, payments_last => time }, + { payments_id => $payment->{payments_id} } + ); + + $log->insert({ + paylogs_payments_id => $payment->{payments_id}, + paylogs_type => LOG_DECLINED, + paylogs_time => time, + paylogs_text => ( + sprintf(Links::language('PAYMENT_REMOTE_RECURRING_DECLINED') => 'WorldPay') . "\n" . + "Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" + ) + }); + } + ); + + print $IN->header; + unless ($end) { + print Links::SiteHTML::display('payment_success'); + } + 1; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Plugins.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Plugins.pm new file mode 100644 index 0000000..5d6b584 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Plugins.pm @@ -0,0 +1,166 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Plugins.pm,v 1.48 2005/04/14 01:08:49 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 Links::Plugins; +# ================================================================== + use strict; + use Links qw/$IN $CFG/; + +# ------------------------------------------------------------------------------------------------- # +# Plugin config # +# ------------------------------------------------------------------------------------------------- # + +sub get_plugin_user_cfg { +# -------------------------------------------------------------- +# Returns the user config hash for a given plugin. +# + my $class = ($_[0] eq 'Links::Plugins') ? shift : ''; + my $plugin_name = shift || return; + my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/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 'Links::Plugins') ? shift : ''; + my $plugin_name = shift || return; + my $hash = shift || return; + + my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/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->{admin_root_path} . '/Plugins', $cfg ); +} + +sub get_plugin_registry { +# -------------------------------------------------------------- +# Returns the user config hash for a given plugin. +# + my $class = ($_[0] eq 'Links::Plugins') ? shift : ''; + my $plugin_name = shift || return; + my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/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 'Links::Plugins') ? shift : ''; + my $plugin_name = shift || return; + my $hash = shift || return; + + my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/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->{admin_root_path} . '/Plugins', $cfg ); +} + + +# ------------------------------------------------------------------------------------------------- # +# 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->{admin_root_path} . "/templates/admin", + plugin_dir => $CFG->{admin_root_path} . "/Plugins", + prog_name => 'lsql', + prog_ver => $CFG->{version}, + prog_reg => $CFG->{reg_number}, + base_url => 'admin.cgi?do=page&page=plugin_manager.html', + path_to_perl => $CFG->{path_to_perl}, + perl_args => "-cw -I$CFG->{admin_root_path}" + ); + return $man->admin_menu; +} + +# ------------------------------------------------------------------------------------------------- # +# 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 = GT::Plugins::Wizard->new( + cgi => $IN, + tpl_root => $CFG->{admin_root_path} . "/templates/admin", + plugin_dir => $CFG->{admin_root_path} . "/Plugins", + prog_ver => $CFG->{version}, + install_header => 'use Links qw/:objects/;', + initial_indent => '', + dirs => { + user_cgi => '$CFG->{admin_root_path}/..', + admin_cgi => '$CFG->{admin_root_path}' + }, + oo => '$PLG' + ); + return $wiz->process; +} + +# ------------------------------------------------------------------------------------------------- # +# Manager # +# ------------------------------------------------------------------------------------------------- # + +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 = GT::Plugins::Manager->new( + cgi => $IN, + tpl_root => $CFG->{admin_root_path} . "/templates/admin", + plugin_dir => $CFG->{admin_root_path} . "/Plugins", + prog_name => 'lsql', + prog_ver => $CFG->{version}, + prog_init => $CFG->{admin_root_path}, + prog_reg => $CFG->{reg_number}, + base_url => 'admin.cgi?do=page&page=plugin_manager.html', + path_to_perl => $CFG->{path_to_perl}, + perl_args => "-cw -I$CFG->{admin_root_path}" + ) or return "Error loading plugin manager: $GT::Plugins::error"; + return $man->process; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/SQL.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/SQL.pm new file mode 100644 index 0000000..6b4cba2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/SQL.pm @@ -0,0 +1,586 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: SQL.pm,v 1.141 2007/11/16 07:15:00 brewt 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. +# ================================================================== + +# Contains the default table structure for Gossamer Links tables. +package Links::SQL; + +use strict; +use vars qw/@TABLES/; +use Links qw/:payment $DB/; + +@TABLES = qw( + Users Links Changes Category CatPrice Reviews CatLinks CatRelations + Editors Verify Sessions EmailTemplates EmailMailings MailingIndex + MailingList MailingListIndex ClickTrack Payments PaymentLogs + Bookmark_Folders Bookmark_Links SearchLogs NewsletterSubscription +); + +sub tables { +# ------------------------------------------------------------------ +# Defines the SQL tables. +# + my $action = shift || 'warn'; + my $output = ''; + + my $ok = Links::language('dialog_ok'); + +# --------- Users Table ---------------- + create_table(\$output, 'Users', $action, + cols => [ + Username => { type => 'CHAR', size => 50, not_null => 1, form_display => Links::language('prompt_Username') }, + Password => { type => 'CHAR', binary => 1, size => 25, not_null => 1, form_display => Links::language('prompt_Password') }, + Email => { type => 'CHAR', size => 75, not_null => 1, regex => '^(?:.+\@.+\..+|\s*)$', form_display => Links::language('prompt_Email') }, + Name => { type => 'CHAR', size => 75, form_display => Links::language('prompt_Name') }, + Validation => { type => 'CHAR', size => 20, , form_display => Links::language('prompt_Validation') }, + Status => { type => 'ENUM', values => ['Not Validated', 'Registered', 'Administrator'], not_null => 1, default => 'Registered', form_display => Links::language('prompt_Status') }, + ReceiveMail => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'Yes', form_display => Links::language('prompt_ReceiveMail') }, + SortField => { type => 'VARCHAR', size => 255, not_null => 1, regex => '^[\s\w]+$', default => 'Title', form_display => Links::language('prompt_SortField') }, + SortOrd => { type => 'ENUM', values => ['ASC', 'DESC'], not_null => 1, default => 'ASC', form_display => Links::language('prompt_SortOrd') }, + PerPage => { type => 'INT', not_null => 1, unsigned => 1, default => 15, form_display => Links::language('prompt_PerPage') }, + Grouping => { type => 'TINYINT', not_null => 1, unsigned => 1, default => 0, form_display => Links::language('prompt_Grouping') }, + ], + index => { + emailndx => ['Email'] + }, + pk => 'Username', + subclass => { + table => { Users => 'Links::Table::Users' }, + html => { Users => 'Links::HTML::Users' } + } + ); + +# --------- Links Table ---------------- + create_table(\$output, 'Links', $action, + cols => [ + ID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_ID') }, + Title => { type => 'CHAR', size => 100, not_null => 1, weight => 3, form_display => Links::language('prompt_Title') }, + URL => { type => 'CHAR', size => 255, not_null => 1, weight => 1, default => 'http://', regex => '^\w+:', form_display => Links::language('prompt_URL') }, + LinkOwner => { type => 'CHAR', size => 50, not_null => 1, default => 'admin', form_display => Links::language('prompt_LinkOwner') }, + Add_Date => { type => 'DATE', not_null => 1, form_display => Links::language('prompt_Add_Date') }, + Mod_Date => { type => 'DATE', not_null => 1, form_display => Links::language('prompt_Mod_Date') }, + Description => { type => 'TEXT', weight => 1, form_display => Links::language('prompt_Description') }, + Contact_Name => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Contact_Name') }, + Contact_Email => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Contact_Email') }, + Hits => { type => 'INT', not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Hits') }, + isNew => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isNew') }, + isChanged => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isChanged') }, + isPopular => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isPopular') }, + isValidated => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'Yes', form_display => Links::language('prompt_isValidated') }, + Rating => { type => 'DECIMAL', precision => 4, scale => 2, not_null => 1, default => 0, regex => '^(?:10(?:\.0*)?|\d(?:\.\d*)?)$', form_display => Links::language('prompt_Rating') }, + Votes => { type => 'SMALLINT', unsigned => 1, not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Votes') }, + Status => { type => 'SMALLINT', not_null => 1, default => 0, regex => '^-?\d+$', form_display => Links::language('prompt_Status') }, + Date_Checked => { type => 'DATETIME', form_display => Links::language('prompt_Date_Checked') }, + Timestmp => { type => 'TIMESTAMP', time_check => 1, form_display => Links::language('prompt_Timestmp') }, + ExpiryDate => { type => 'INT', not_null => 1, default => FREE, form_display => Links::language('prompt_ExpiryDate'), form_size => 35 }, # See FREE, UNPAID & UNLIMITED constants in Links.pm + ExpiryCounted => { type => 'TINYINT', not_null => 1, default => 0, form_display => Links::language('prompt_ExpiryCounted'), form_type => 'hidden' }, + ExpiryNotify => { type => 'TINYINT', not_null => 1, default => 0, form_display => Links::language('prompt_ExpiryNotify'), form_type => 'hidden' }, + LinkExpired => { type => 'INT', form_display => Links::language('prompt_LinkExpired'), form_type => 'hidden' }, + ], + pk => 'ID', + ai => 'ID', + fk => { + Users => { LinkOwner => 'Username' } + }, + index => { + urlndx => ['URL'], + stndx => ['Status'], + valexpndx => [qw/isValidated ExpiryDate/], + newndx => ['isNew'], + popndx => ['isPopular'], + userndx => ['LinkOwner'], + expiryndx => [qw/ExpiryDate ExpiryNotify/], + expcntndx => [qw/ExpiryCounted ExpiryDate/] + }, + subclass => { + table => { Links => 'Links::Table::Links' }, + html => { Links => 'Links::HTML::Links' } + } + ); + +# --------- Changes Table ---------------- + create_table(\$output, 'Changes', $action, + cols => [ + LinkID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' }, + Username => { type => 'CHAR', size => 50, not_null => 1, default => 'admin' }, + ChgRequest => { type => 'TEXT' }, + Timestmp => { type => 'TIMESTAMP' } + ], + fk => { + Links => { LinkID => 'ID' }, + Users => { Username => 'Username' } + } + ); + +# --------- Category Table ---------------- + my $new_category = create_table(\$output, 'Category', $action, + cols => [ + ID => { type => 'INT', not_null => 1, unsigned => 1, form_display => Links::language('prompt_ID') }, + Name => { type => 'CHAR', size => 255, not_null => 1, weight => 3, regex => '^[^/]+$', form_display => Links::language('prompt_Name') }, + FatherID => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_size => 1, form_display => Links::language('prompt_FatherID') }, + CatRoot => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' }, + CatDepth => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' }, + Full_Name => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Full_Name') }, + Description => { type => 'TEXT', weight => 1, form_display => Links::language('prompt_Description') }, + Meta_Description => { type => 'TEXT', form_display => Links::language('prompt_Meta_Description') }, + Meta_Keywords => { type => 'TEXT', form_display => Links::language('prompt_Meta_Keywords') }, + Header => { type => 'TEXT', form_display => Links::language('prompt_Header') }, + Footer => { type => 'TEXT', form_display => Links::language('prompt_Footer') }, + Category_Template => { type => 'CHAR', size => 20, form_display => Links::language('prompt_Category_Template') }, + Number_of_Links => { type => 'INT', not_null => 1, default => 0, form_display => Links::language('prompt_Number_of_Links') }, + Direct_Links => { type => 'INT', not_null => 1, default => 0, form_display => Links::language('prompt_Direct_Links') }, + Has_New_Links => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Has_New_Links') }, + Has_Changed_Links => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Has_Changed_Links') }, + Newest_Link => { type => 'DATE', form_display => Links::language('prompt_Newest_Link') }, + Timestmp => { type => 'TIMESTAMP', time_check => 1, form_display => Links::language('prompt_Timestmp') }, + Payment_Mode => { type => 'TINYINT', not_null => 1, default => 0, form_size => 1, form_names => [GLOBAL,NOT_ACCEPTED,OPTIONAL,REQUIRED], form_values => ['Use global settings','Not accepted','Optional','Required'], form_type => 'SELECT', form_display => Links::language('prompt_Payment_Mode') }, + Payment_Description => { type => 'TEXT', form_display => Links::language('prompt_Payment_Description') }, + ], + subclass => { + table => { Category => 'Links::Table::Category' }, + html => { Category => 'Links::HTML::Category' } + }, + pk => 'ID', + ai => 'ID', + index => { + catndx => ['Name'], + namndx => ['Full_Name'], + fthrindex => ['FatherID'], + rootndx => ['CatRoot'], + c_p => ['Payment_Mode'], + } + ); + +# --------- Category Tree ------------------------- + $output .= "Creating Category tree... "; + my $e = $DB->editor('Category'); + if ($e->add_tree(father => "FatherID", root => "CatRoot", depth => "CatDepth", force => ($new_category ? 'force' : 'check'))) { + $output .= "okay\n"; + } + else { + $output .= "failed ($GT::SQL::error)\n"; + } + +# --------- CatPrice Table ---------------- + create_table(\$output, 'CatPrice', $action, + cols => [ + cp_id => { type => 'INT', not_null => 1, unsigned => 1 }, + cp_cat_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + cp_term => { type => 'CHAR', not_null => 1, size => 10 }, # e.g. 8d, 1m, 2y, 3w, unlimited, etc. + cp_cost => { type => 'DOUBLE', not_null => 1 }, + cp_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = signup, 1 = renewal, 2 = recurring + cp_description => { type => 'TEXT' } + ], + pk => 'cp_id', + ai => 'cp_id', + fk => { + Category => { cp_cat_id_fk => 'ID' } + } + ); + +# --------- Reviews Table ---------------- + create_table(\$output, 'Reviews', $action, + cols => [ + ReviewID => { type => 'INT', not_null => 1, unsigned => 1, form_display => Links::language('prompt_ReviewID') }, + Review_LinkID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_LinkID') }, + Review_Owner => { type => 'CHAR', size => 50, not_null => 1, form_display => Links::language('prompt_Review_Owner') }, + Review_Rating => { type => 'SMALLINT', unsigned => 1, not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Review_Rating') }, + Review_Date => { type => 'DATETIME', not_null => 1, form_display => Links::language('prompt_Review_Date') }, + Review_ModifyDate => { type => 'DATETIME', not_null => 1, form_display => Links::language('prompt_Review_ModifyDate') }, + Review_Subject => { type => 'CHAR', size => 100, not_null => 1, form_display => Links::language('prompt_Review_Subject') }, + Review_Contents => { type => 'TEXT', not_null => 1, form_display => Links::language('prompt_Review_Contents') }, + Review_ByLine => { type => 'CHAR', size => 50, form_display => Links::language('prompt_Review_ByLine') }, + Review_WasHelpful => { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_WasHelpful') }, + Review_WasNotHelpful => { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_WasNotHelpful') }, + Review_Validated => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Review_Validated') }, + Review_GuestName => { type => 'CHAR', size => 75, form_display => Links::language('prompt_Review_GuestName') }, + Review_GuestEmail => { type => 'CHAR', size => 75, regex => '^(?:(?:.+\@.+\..+)|\s*)$', form_display => Links::language('prompt_Review_GuestEmail') }, + ], + pk => 'ReviewID', + ai => 'ReviewID', + subclass => { + table => { Reviews => 'Links::Table::Reviews' } + }, + index => { + rownerndx => ['Review_Owner'], + rdatendx => ['Review_Date'], + rlinkndx => ['Review_LinkID'] + }, + fk => { + Links => { Review_LinkID => 'ID' }, + Users => { Review_Owner => 'Username' } + } + ); + +# --------- CatLinks Table ---------------- + create_table(\$output, 'CatLinks', $action, + cols => [ + LinkID => { type => 'INT', not_null => 1, unsigned => 1 }, + CategoryID => { type => 'INT', not_null => 1, unsigned => 1 } + ], + subclass => { + table => { CatLinks => 'Links::Table::CatLinks' } + }, + index => { + lndx => ['LinkID'] + }, + unique => { + cl_cl_q => [qw/CategoryID LinkID/] + }, + fk => { + Links => { LinkID => 'ID' }, + Category => { CategoryID => 'ID' } + } + ); + +# --------- CatRelations Table ---------------- + create_table(\$output, 'CatRelations', $action, + cols => [ + CategoryID => { type => 'INT', not_null => 1, unsigned => 1 }, + RelatedID => { type => 'INT', not_null => 1, unsigned => 1 }, + RelationName => { type => 'VARCHAR', size => 255 } + ], + index => { + catid => ['CategoryID'] + }, + fk => { + Category => { CategoryID => 'ID', RelatedID => 'ID' } + } + ); + +# --------- User Editors Table ---------------- + create_table(\$output, 'Editors', $action, + cols => [ + Username => { type => 'CHAR', size => 50, not_null => 1 }, + CategoryID => { type => 'INT', unsigned => 1, not_null => 1 }, + CanAddCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanModCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanDelCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanMoveCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanAddLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanDelLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanModLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanCopyLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanMoveLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanValLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanModReview => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanAddRel => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + CanAddEdit => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }, + ], + unique => { + edituserndx => ['Username', 'CategoryID'] + }, + fk => { + Users => { Username => 'Username' }, + Category => { CategoryID => 'ID' } + } + ); + +# --------- Verify History Table ---------------- + create_table(\$output, 'Verify', $action, + cols => [ + LinkID => { type => 'INT', unsigned => 1, not_null => 1 }, + Status => { type => 'SMALLINT', not_null => 1, default => 0 }, + Date_Checked => { type => 'DATE' } + ], + index => { + veriflndx => ['LinkID'] + }, + fk => { + Links => { LinkID => 'ID' } + } + ); + +# --------- Session Table ---------------- + create_table(\$output, 'Sessions', $action, + cols => [ + session_id => { type => 'CHAR', size => 32, not_null => 1, binary => 1 }, + session_user_id => { type => 'CHAR', size => 50, not_null => 1 }, + session_date => { type => 'INT', not_null => 1 }, + session_expires => { type => 'TINYINT', default => 1 }, + session_data => { type => 'TEXT' } + ], + pk => 'session_id', + fk => { + Users => { session_user_id => 'Username' } + } + ); + +# --------- Email Template Table ---------------- + create_table(\$output, 'EmailTemplates', $action, + cols => [ + Name => { type => 'CHAR', size => 50, not_null => 1, regex => '\S' }, + MsgFrom => { type => 'TEXT', not_null => 1, regex => '\A(?:\S+\@[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)+)\Z' }, + MsgFromName => { type => 'TEXT', not_null => 1 }, + Subject => { type => 'TEXT', not_null => 1 }, + Message => { type => 'MEDIUMTEXT', not_null => 1 }, + MessageFormat => { type => 'ENUM', values => [qw[text html]], not_null => 1, default => 'text' }, + LinkTemplate => { type => 'MEDIUMTEXT' } + ], + pk => 'Name' + ); + +# --------- Email Mailings Table ------------- + create_table(\$output, 'EmailMailings', $action, + cols => [ + ID => { type => 'INT', unsigned => 1, not_null => 1 }, + Mailing => { type => 'INT', unsigned => 1, not_null => 1 }, + Email => { type => 'TEXT', size => 75, not_null => 1 }, + Sent => { type => 'TINYINT', default => 0, not_null => 1 }, + LinkID => { type => 'INT', unsigned => 1 } # If this is a sending to link owners, this will hold the Link ID + ], + pk => 'ID', + ai => 'ID' + ); + +# --------- Email Mailing Index Table -------- + create_table(\$output, 'MailingIndex', $action, + cols => [ + Mailing => { type => 'INT', unsigned => 1, not_null => 1 }, + extra => { type => 'TINYTEXT', not_null => 1 }, + done => { type => 'INT' }, + mailfrom => { type => 'TEXT', not_null => 1 }, + name => { type => 'TEXT', not_null => 1 }, + subject => { type => 'TEXT', not_null => 1 }, + message => { type => 'MEDIUMTEXT', not_null => 1 }, + messageformat => { type => 'ENUM', values => [qw[text html]], not_null => 1, default => 'text' }, + ], + pk => 'Mailing', + ai => 'Mailing' + ); + +# --------- MailingList Table ---------------- + create_table(\$output, 'MailingList', $action, + cols => [ + ID => { type => 'INT', not_null => 1 }, + Email => { type => 'CHAR', size => 255, not_null => 1 } + ], + index => { + maillistndx => ['Email'] + } + ); + +# --------- MailingListIndex Table ---------------- + create_table(\$output, 'MailingListIndex', $action, + cols => [ + ID => { type => 'INT', unsigned => 1, not_null => 1 }, + Name => { type => 'CHAR', size => 255, not_null => 1 }, + DateModified => { type => 'INT', not_null => 1 }, + DateCreated => { type => 'INT', not_null => 1 } + ], + pk => 'ID', + ai => 'ID' + ); + +# --------- ClickTrack Table ---------------- + create_table(\$output, 'ClickTrack', $action, + cols => [ + LinkID => { type => 'INT', not_null => 1 }, + IP => { type => 'CHAR', size => 16, not_null => 1 }, + ClickType => { type => 'ENUM', values => ['Rate', 'Hits','Review'], not_null => 1 }, + ReviewID => { type => 'INT', not_null => 1, default => 0}, + Created => { type => 'TIMESTAMP' } + ], + subclass => { + table => { ClickTrack => 'Links::Table::ClickTrack' } + }, + unique => { + ct_licr => ['LinkID', 'IP', 'ClickType','ReviewID'] + }, + index => { + cndx => ['Created'] + } + ); + +# --------- Payments Table ---------------- + create_table(\$output, 'Payments', $action, + cols => [ + payments_id => { type => 'CHAR', not_null => 1, size => 16 }, + payments_linkid => { type => 'INT', unsigned => 1, not_null => 1 }, + payments_status => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = pending, 1 = completed, 2 = declined, 3 = error + payments_method => { type => 'CHAR', not_null => 1, size => 25 }, + payments_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = initial payment, 1 = renewal payment, 2 = recurring payment + payments_amount => { type => 'DOUBLE', not_null => 1 }, + payments_term => { type => 'CHAR', not_null => 1, size => 10 }, # e.g. 8d, 1m, 2y, 3w, unlimited, etc. + payments_start => { type => 'INT', not_null => 1, unsigned => 1 }, + payments_last => { type => 'INT', not_null => 1, unsigned => 1 }, + ], + pk => 'payments_id', + fk => { + Links => { payments_linkid => 'ID' } + }, + index => { + p_sl => ['payments_status', 'payments_last'], + p_ll => ['payments_linkid', 'payments_last'], + p_al => ['payments_amount', 'payments_last'], + } + ); + +# --------- Payment Logs Table ---------------- + create_table(\$output, 'PaymentLogs', $action, + cols => [ + paylogs_id => { type => 'INT', not_null => 1, unsigned => 1 }, + paylogs_payments_id => { type => 'CHAR', not_null => 1, size => 16 }, + paylogs_type => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = info, 1 = accepted, 2 = declined, 3 = error + paylogs_time => { type => 'INT', not_null => 1, unsigned => 1 }, + paylogs_viewed => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 }, + paylogs_text => { type => 'TEXT' }, + ], + pk => 'paylogs_id', + ai => 'paylogs_id', + fk => { + Payments => { paylogs_payments_id => 'payments_id' } + }, + index => { + pl_yt => ['paylogs_type', 'paylogs_time'], + pl_t => ['paylogs_time'] + } + ); + +# --------- Bookmark Folders Table ---------------- + create_table(\$output, 'Bookmark_Folders', $action, + cols => [ + my_folder_id => { type => 'INT', not_null => 1, unsigned => 1 }, + my_folder_name => { type => 'VARCHAR', not_null => 1, size => 255 }, + my_folder_description => { type => 'VARCHAR', size => 255 }, + my_folder_user_username_fk => { type => 'VARCHAR', size => 50 }, + my_folder_default => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 }, + my_folder_public => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 } + ], + pk => 'my_folder_id', + ai => 'my_folder_id', + fk => { + Users => { my_folder_user_username_fk => 'Username' } + } + ); + +# --------- Bookmark Links Table ---------------- + create_table(\$output, 'Bookmark_Links', $action, + cols => [ + my_id => { type => 'INT', not_null => 1, unsigned => 1 }, + my_link_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + my_user_username_fk => { type => 'VARCHAR', size => 50 }, + my_folder_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + my_comment => { type => 'VARCHAR', size => '255' } + ], + pk => 'my_id', + ai => 'my_id', + fk => { + Users => { my_user_username_fk => 'Username' }, + Bookmark_Folders => { my_folder_id_fk => 'my_folder_id' }, + Links => { my_link_id_fk => 'ID' }, + } + ); + +# --------- SearchLogs Table ---------------- + create_table(\$output, 'SearchLogs', $action, + cols => [ + slog_query => { type => 'VARCHAR', not_null => 1, size => 255 }, + slog_count => { type => 'INT', not_null => 1, default => 0 }, + slog_hits => { type => 'INT', not_null => 1, default => 0 }, + slog_time => { type => 'FLOAT' }, + slog_last => { type => 'INT', not_null => 1, default => 0 }, + ], + pk => 'slog_query' + ); + +# --------- Newsletter Subscription Table ---------------- + create_table(\$output, 'NewsletterSubscription', $action, + cols => [ + UserID => { type => 'CHAR', size => 50 }, + CategoryID => { type => 'INT', not_null => 1 }, + ], + unique => { + ns_uc => ['UserID', 'CategoryID'] + }, + fk => { + Users => { UserID => 'Username' }, + Category => { CategoryID => 'ID' } + } + ); + + return $output; +} + +sub create_table { + my ($output, $table, $action, @def) = @_; + + $$output .= Links::language('dialog_create', $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 .= Links::language('dialog_ok'); + return 1; + } + else { + $$output .= Links::language($GT::SQL::errcode eq 'TBLEXISTS' ? ('error_failed_exists') : ('error_failed_other', $GT::SQL::error)); + $GT::SQL::errcode if 0; # silence "used only once" warning + $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) { + if ($table eq 'Links' or $table eq 'Users' or $table eq 'Category') { + $c->subclass( + table => { $table => "Links::Table::$table" }, + html => { $table => "Links::HTML::$table" } + ); + } + elsif ($table eq 'CatLinks' or $table eq 'ClickTrack') { + $c->subclass( + table => { $table => "Links::Table::$table" } + ); + } + $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; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/SiteHTML.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/SiteHTML.pm new file mode 100644 index 0000000..050cb9a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/SiteHTML.pm @@ -0,0 +1,313 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: SiteHTML.pm,v 1.89 2008/04/29 04:02:34 brewt 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 Links::SiteHTML; +# ================================================================== +use strict; +use Links qw/:objects :payment/; + +sub display { +# ----------------------------------------------------------------- +# Returns a specified template parsed. +# + my ($template, $vars, $opts) = @_; + my $code = exists $Links::SiteHTML::{"site_html_$template"} ? $Links::SiteHTML::{"site_html_$template"} : _compile("site_html_$template"); + defined $code or die "Invalid method: site_html_$template called."; + + $PLG->dispatch("site_html_$template", $code, $vars, $opts); +} + +sub tags { +# ----------------------------------------------------------------- +# Returns the tags needed to properly include a template in another template, +# instead of returning parsed HTML like display(). Currently only supports +# 'link' for formatted link information. +# + my ($sub, $vars, $opts) = @_; + my $code = exists $Links::SiteHTML::{"site_tags_$sub"} && $Links::SiteHTML::{"site_tags_$sub"}; + defined $code or die "Invalid method: site_tags_$sub called."; + + $PLG->dispatch("site_tags_$sub", $code, $vars, $opts); +} + +# All the templates are auto-loaded, except for the ones below which need +# to do some special stuff. + +sub site_tags_link { +# -------------------------------------------------------- +# Format the tags for a single link. +# + my ($vars, $cat_id) = @_; + + my %block = $Links::GLOBALS ? map { $_ => 1 } keys %$Links::GLOBALS : (); + my %rec = map { exists $block{$_} ? () : ($_ => $vars->{$_}) } keys %$vars; + + $rec{Add_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec{Add_Date}, GT::Date::FORMAT_DATE)); + $rec{Mod_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec{Mod_Date}, GT::Date::FORMAT_DATE)); + +# Convert the date formats. + if (GT::Date::FORMAT_DATE ne $CFG->{date_user_format}) { + Links::init_date(); + $rec{Add_Date} = GT::Date::date_transform($rec{Add_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec{Add_Date}; + $rec{Mod_Date} = GT::Date::date_transform($rec{Mod_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec{Mod_Date}; + } + +# Set new and pop to either 1 or undef for templates. + $rec{isNew} = ($rec{isNew} and ($rec{isNew} eq 'Yes' or $rec{isNew} eq '1')) ? 1 : 0; + $rec{isChanged} = ($rec{isChanged} and ($rec{isChanged} eq 'Yes' or $rec{isChanged} eq '1')) ? 1 : 0; + $rec{isPopular} = ($rec{isPopular} and ($rec{isPopular} eq 'Yes' or $rec{isPopular} eq '1')) ? 1 : 0; + $rec{isLinkOwner} = ($USER and defined $USER->{Username} and $rec{LinkOwner} eq $USER->{Username}) ? 1 : 0; + + $rec{paymentsEnabled} = 0; # The payment url is disabled by default + + if ($CFG->{payment}->{enabled}) { + my $catp; +# Fetch payment information for the category the link is in (used below to determine if the payment data should be shown) + my @cid = $DB->table('CatLinks')->select('CategoryID', { LinkID => $rec{ID} })->fetchall_list; + require Links::Payment; + $catp = Links::Payment::load_cat_price(\@cid); + + # Add various extra tags regarding payment if the current user is the link owner: + if ($rec{isLinkOwner} and $rec{ExpiryDate} != UNLIMITED and $catp->{payment_mode} != NOT_ACCEPTED) { + my $expiry_date = $rec{ExpiryDate}; + my $notify_date = time + $CFG->{payment}->{expiry_notify} * (24*60*60); + $rec{paymentsEnabled} = 1; + $rec{isUnpaid} = $expiry_date == UNPAID; + $rec{isFree} = $expiry_date == FREE; + $rec{isExpired} = ($expiry_date > UNPAID and $expiry_date < time or $rec{isFree} and $rec{LinkExpired}); + $rec{wasPaid} = ($expiry_date > UNPAID and $expiry_date < FREE or $rec{isFree} and $rec{LinkExpired}); + $rec{ExpiryDateFormatted} = ($expiry_date > UNPAID and $expiry_date < FREE) + ? GT::Date::date_get($expiry_date, $CFG->{date_expiry_format}) + : ($rec{isFree} and $rec{LinkExpired}) + ? GT::Date::date_get($rec{LinkExpired}, $CFG->{date_expiry_format}) + : ''; + $rec{isNotify} = ($expiry_date >= time and $expiry_date <= $notify_date) ? 1 : 0; + } + + $rec{isPaidLink} = 0; + $rec{isFreeLink} = 0; + if ($rec{ExpiryDate} >= time and $rec{ExpiryDate} < FREE) { + $rec{isPaidLink} = 1; + } + elsif ($rec{ExpiryDate} == FREE) { + $rec{isFreeLink} = 1; + } + } + + my $links = $DB->table('Links'); + if ($CFG->{build_detailed}) { + my $detailed; +# Generate the detailed url for a specific the category that we're in (a link may be in multiple categories) + if ($cat_id) { + $detailed = $links->category_detailed_url($cat_id, $rec{ID}); + } + else { + $detailed = $links->detailed_url($rec{ID}); + } + $rec{detailed_url} = "$CFG->{build_detail_url}/$detailed"; + } + +# Load any reviews, if not already done + $links->add_reviews(\%rec) unless exists $rec{Review_Loop}; + + \%rec; +} + +sub site_html_link { +# -------------------------------------------------------- +# Format and return the HTML for a single link. +# +# Note that this method is deprecated in favour of generating all the html in +# the templates. Instead, you should be doing: +# <%Links::Utils::load_link_info%><%include link.html%> +# + my $rec = tags(link => @_); + +# Set the template set to use. + my $opts = { dynamic => 0 }; + if ($rec->{Category_Template} and $rec->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) { + $opts->{template} = delete $rec->{Category_Template}; + } + +# Parse the template. + return Links::user_page('link.html', $rec, $opts); +} + +sub site_html_detailed { +# -------------------------------------------------------- +# Return parsed detailed page (one link per html page). +# + my $rec = shift; + + $rec->{Add_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec->{Add_Date}, GT::Date::FORMAT_DATE)); + $rec->{Mod_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec->{Mod_Date}, GT::Date::FORMAT_DATE)); + +# Convert the date formats. + if (GT::Date::FORMAT_DATE ne $CFG->{date_user_format}) { + Links::init_date(); + $rec->{Add_Date_orig} = $rec->{Add_Date}; + $rec->{Add_Date} = GT::Date::date_transform($rec->{Add_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec->{Add_Date}; + $rec->{Mod_Date_orig} = $rec->{Mod_Date}; + $rec->{Mod_Date} = GT::Date::date_transform($rec->{Mod_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec->{Mod_Date}; + } + +# Set new and pop to either 1 or undef for templates. + $rec->{isNew} = ($rec->{isNew} and ($rec->{isNew} eq 'Yes' or $rec->{isNew} eq '1')) ? 1 : 0; + $rec->{isChanged} = ($rec->{isChanged} and ($rec->{isChanged} eq 'Yes' or $rec->{isChanged} eq '1')) ? 1 : 0; + $rec->{isPopular} = ($rec->{isPopular} and ($rec->{isPopular} eq 'Yes' or $rec->{isPopular} eq '1')) ? 1 : 0; + $rec->{isLinkOwner} = ($USER and defined $USER->{Username} and $rec->{LinkOwner} eq $USER->{Username}) ? 1 : 0; + + if ($CFG->{payment}->{enabled}) { + $rec->{isPaidLink} = 0; + $rec->{isFreeLink} = 0; + if ($rec->{ExpiryDate} >= time and $rec->{ExpiryDate} < FREE) { + $rec->{isPaidLink} = 1; + } + elsif ($rec->{ExpiryDate} == FREE) { + $rec->{isFreeLink} = 1; + } + } + +# Set the template set to use. + my $opts = { dynamic => 1 }; + if ($rec->{Category_Template} and $rec->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) { + $opts->{template} = delete $rec->{Category_Template}; + } + + my $output = Links::user_page('detailed.html', $rec, $opts); + return $output; +} + +sub site_html_category { +# -------------------------------------------------------- +# Return parsed category page. +# + my $tags = shift; + + $tags->{build_links_per_page} = $CFG->{build_links_per_page}; + ($tags->{category_first}) = $tags->{'category_name'} =~ m,/?([^/]+)$,; + + my $opts = { dynamic => 1 }; + +# Find the proper template. + my $template = 'category.html'; + +# If the Category_Template ends with .htm or .html, then use that file as a template, otherwise, use it as a template set. + if ($tags->{Category_Template} and $tags->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) { + $opts->{template} = delete $tags->{Category_Template}; + } + elsif ($tags->{Category_Template}) { + $template = $tags->{Category_Template}; + } + my $output = Links::user_page($template, $tags, $opts); + return $output; +} + +sub site_html_print_cat { +# -------------------------------------------------------- +# This routine prints out a list of categories. +# +# Note that this method has been deprecated in favour of using loops and +# performing html generation in the templates. If you need to modify +# the category data, use the build_category_loop plugin hook. +# + my @subcat = @{$_[0]}; + my $parent_cat = shift @subcat; + my $breakpoint = int(@subcat / $CFG->{build_category_columns}); + $breakpoint++ if @subcat % $CFG->{build_category_columns}; + my $table_head = $CFG->{build_category_table} || ''; + my $width = int(100 / $CFG->{build_category_columns}); + my $output = ''; + my $i = 0; + my $cat_db = $DB->table('Category'); + my $opts = { dynamic => 0 }; + +# Print Header. + if ($CFG->{build_category_columns}) { + $output = qq|
        \n
        \n|; + } + +# Figure out if we should use a different template. + if ($parent_cat->{Category_Template} and $parent_cat->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) { + $opts->{template} = delete $parent_cat->{Category_Template}; + } + +# Go through each subcategory and print its template. + for my $cat_r (@subcat) { + $cat_r->{Short_Name} = $cat_r->{Name} =~ m,.*/([^/]+)$, ? $1 : $cat_r->{Name}; + $cat_r->{URL} ||= $CFG->{build_root_url} . "/" . $cat_db->as_url($cat_r->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + +# Set the short name. + if ($cat_r->{Related}) { + if ($cat_r->{RelationName}) { + $cat_r->{Short_Name} = $cat_r->{RelationName}; + } + else { + if (exists $parent_cat->{Name} and ($cat_r->{Short_Name} eq $parent_cat->{Name})) { + my ($short) = $cat_r->{Full_Name} =~ m,([^/]+)/[^/]*$,; + $short and ($cat_r->{Short_Name} = $short); + } + else { + $cat_r->{Short_Name} = $cat_r->{Short_Name}; + } + } + } + +# We check to see if we are half way through, if so we stop this table cell +# and begin a new one (this lets us have category names in two columns). + if ($CFG->{build_category_columns}) { + $output .= qq|\n| if $i > 0 and not $i % $breakpoint; + $i++; + } + $output .= Links::user_page('subcategory.html', $cat_r, $opts); + } + +# Don't forget to end the table properly .. + if ($CFG->{build_category_columns}) { + $output .= "
        \n"; + } + return $output; +} + +sub site_html_error { +# -------------------------------------------------------- +# Print out the error page +# + my ($vars, $opts) = @_; + $opts ||= { dynamic => 1 }; + unless (exists $vars->{main_title_loop}) { + require Links::Build; + $vars->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ERROR'), $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : ''))); + } + return Links::user_page('error.html', $vars, $opts); +} + +sub _compile { +# ------------------------------------------------------------------- +# Compile dynamically creates site_html routines if a template file +# exists. +# + my $sub = shift; + my ($file) = $sub =~ /^site_html_([\w-]+)$/; + $file or return sub { display('error', { error => "Invalid SiteHTML method: '" . $IN->html_escape($sub) . "'." }) }; + $file .= '.html'; + my $template_set = Links::template_set(); + unless (Links::template_exists($template_set, $file)) { + return sub { display('error', { error => "Invalid SiteHTML method: $sub ($file). The template does not exist in '$template_set'." }) }; + } + my $code = sub { my ($vars, $opts) = @_; $opts ||= { dynamic => 1 }; return Links::user_page($file, $vars, $opts) }; + $Links::SiteHTML::{$sub} = $code; + $code; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/CatLinks.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/CatLinks.pm new file mode 100644 index 0000000..8245fc2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/CatLinks.pm @@ -0,0 +1,95 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: CatLinks.pm,v 1.4 2006/03/25 01:13:35 brewt 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 Links::Table::CatLinks; +# ================================================================== +use strict; +use Links qw/:payment :objects/; +use GT::SQL; +use GT::SQL::Table; +use vars qw /@ISA $ERROR_MESSAGE @DELETING/; + +@ISA = qw/GT::SQL::Table/; +$ERROR_MESSAGE = 'GT::SQL'; +@DELETING = (); # Used by Links::Table::Links + +sub delete { +# ----------------------------------------------------------------------------- +# We override the default CatLinks delete to delete any links that will no +# longer be referenced as a result of the deletion. +# + my ($self, $cond) = @_; + + ref $cond or return $self->fatal(BADARGS => '$catlinks->delete(condition)'); + +# Get the CatLinks rows that are about to be deleted + my (%delete, %links); + my $sth = $self->select($cond); + while (my $row = $sth->fetchrow_hashref) { + $delete{$row->{LinkID}}++; + if (exists $links{$row->{LinkID}}) { + push @{$links{$row->{LinkID}}}, $row->{CategoryID}; + } + else { + $links{$row->{LinkID}} = [$row->{CategoryID}]; + } + } + +# Delete the CatLinks rows + my $ret = $self->SUPER::delete($cond) or return; + +# Get the links that still exist in the CatLinks table after the delete (ie. +# links that were in multiple categories). These are the links that shouldn't +# be deleted from the Links table. + my @remaining = keys %delete ? $self->select('LinkID', { LinkID => [keys %delete] })->fetchall_list : (); + for (@remaining, @DELETING) { + delete $delete{$_}; + } + +# Non-validated links don't increment Category counts. + my @notval = keys %links ? $DB->table('Links')->select('ID', { ID => [keys %links], isValidated => 'No' })->fetchall_list : (); + for (@notval, @DELETING) { + delete $links{$_}; + } + +# Any links in %delete have no references to it from CatLinks + if (keys %delete) { + $DB->table('Links')->delete({ ID => [keys %delete] }); + } + +# Build a list of categories that need their counts updated + my %cats; + for (keys %links) { + for (@{$links{$_}}) { + $cats{$_}++; + } + } + +# Update the Category link counts + if (keys %cats) { + my $category = $DB->table('Category'); + my %change; + while (my ($catid, $count) = each %cats) { + push @{$change{-$count}}, $catid; + } + $category->link_count(\%change); + + while (my ($change, $ids) = each %change) { + $category->update({ Direct_Links => \("Direct_Links - " . abs $change) }, { ID => $ids }); + } + } + + $ret; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Category.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Category.pm new file mode 100644 index 0000000..20cf0d4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Category.pm @@ -0,0 +1,638 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Category.pm,v 1.29 2009/05/11 05:57:45 brewt 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 Links::Table::Category; +# ================================================================== +use strict; +use Links qw/:payment :objects/; +use GT::SQL; +use GT::SQL::Table; +use GT::Lock qw/lock unlock LOCK_TRY/; +use vars qw /@ISA $ERRORS $ERROR_MESSAGE/; + +@ISA = qw/GT::SQL::Table/; +$ERROR_MESSAGE = 'GT::SQL'; +$ERRORS = { + BADCATNAME => "Invalid category name: %s", + BADCATID => "Invalid category id: %s", + BADCATSUG => "There is no category with that name. Perhaps you meant: %s", + CATEXISTS => "A category with the name '%s' already exists.", +}; + +# We wrap new() to handle updating Number_of_Links - but only once: the first +# time a Category table object is created. +sub new { + my $self = shift->SUPER::new(@_) or return; + + return $self if $STASH{expired_links}++; + + my $links = $DB->table('Links'); + my $cond; + if ($CFG->{payment}->{enabled}) { + $cond = GT::SQL::Condition->new( + ExpiryCounted => '=' => 0, + ExpiryDate => '<' => time, + isValidated => '=' => 'Yes' + ); + } + else { + $cond = GT::SQL::Condition->new( + ExpiryCounted => '=' => 1, + isValidated => '=' => 'Yes' + ); + } + # Don't select the ID's here because we haven't established a lock. Since + # most requests won't catch expired links, doing a count here to avoid + # needing the lock is going to be slightly slower occassionally, but + # usually faster. + return $self unless $links->count($cond); + + # We've now determined that there _are_ links that have expired that + # haven't been counted yet, so we establish a lock (to prevent a race + # condition), and then update the links counts for categories that have + # newly-expired links. If getting the lock fails, simply return - this is + # only likely to happen when another process has the lock and is performing + # the updates already, or when a previous process with a lock died - the + # 120 should make sure that such a condition doesn't last longer than 2 + # minutes. + lock cat_link_count => 1, LOCK_TRY, 120 + or return $self; + + my @links = $links->select(ID => $cond)->fetchall_list; + unless (@links) { # Despite the above count, there might not be links now if we had to wait for a lock + unlock 'cat_link_count'; + return $self; + } + + if ($CFG->{payment}->{expired_is_free}) { + # This gets a bit hairy - expired links need to become free but NOT in + # required categories. On the other hand, links in non-required + # categories don't affect the count. + my %req_links = map { $_ => 1 } $DB->table('Category', 'CatLinks')->select(LinkID => { LinkID => \@links, Payment_Mode => $CFG->{payment}->{mode} == REQUIRED ? [GLOBAL, REQUIRED] : REQUIRED })->fetchall_list; + my @to_free = grep !$req_links{$_}, @links; + if (@to_free) { + $DB->table('Links')->update({ LinkExpired => \'ExpiryDate' }, { ID => \@to_free }); + $DB->table('Links')->update({ ExpiryDate => FREE }, { ID => \@to_free }); + } + @links = keys %req_links; + unless (@links) { + unlock 'cat_link_count'; + return $self; + } + } + my $catlinks = $DB->table('CatLinks'); + $catlinks->select_options('GROUP BY CategoryID'); + my %cats = $catlinks->select(CategoryID => 'COUNT(*)' => { LinkID => \@links })->fetchall_list; # FIXME this query can be huge and will fail (the select() will fail and return undef) + my %adjust; + my %direct_adj; + + my $parents = $self->parents([keys %cats]); + for my $cat_id (keys %cats) { + $adjust{$cat_id} ||= 0; + $adjust{$cat_id} += $cats{$cat_id}; + $direct_adj{$cat_id} ||= 0; + $direct_adj{$cat_id} += $cats{$cat_id}; + for (@{$parents->{$cat_id}}) { + $adjust{$_} ||= 0; + $adjust{$_} += $adjust{$cat_id}; + } + } + + my %change; + while (my ($id, $change) = each %adjust) { + push @{$change{$CFG->{payment}->{enabled} ? -$change : $change}}, $id; + } + my %change_direct; + while (my ($id, $change) = each %direct_adj) { + push @{$change_direct{$CFG->{payment}->{enabled} ? -$change : $change}}, $id; + } + + while (my ($adjust, $ids) = each %change) { + $self->update({ Number_of_Links => \("Number_of_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids }); + } + while (my ($adjust, $ids) = each %change_direct) { + $self->update({ Direct_Links => \("Direct_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids }); + } + + $links->update({ ExpiryCounted => $CFG->{payment}->{enabled} ? 1 : 0 }, { ID => \@links }); + + unlock 'cat_link_count'; + + return $self; +} + +sub add { +# ------------------------------------------------------------------- +# Adds a category, but passes it through the plugin system. +# + my $self = shift; + my $p = (ref $_[0] eq 'HASH') ? shift : {@_}; + + $PLG->dispatch('add_category', sub { return $self->_plg_add(@_) }, $p); +} + +sub _plg_add { +# ------------------------------------------------------------------- +# Add a category. +# + my ($self, $p) = @_; + + $self->can_add($p) or return; + +# If successful, we need to update timestamps of parents to denote a change. + if (my $id = $self->SUPER::add($p)) { + if ($p->{FatherID}) { + $self->update( + { Timestmp => \"NOW()" }, + { ID => $self->parents($id) }, + { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 } + ); + } + return $id; + } + else { + return; + } +} + +sub can_add { +# ------------------------------------------------------------------- +# Confirms that a category can be added. +# + my $self = shift; + my $p = $self->common_param(@_) or return $self->warn(BADARGS => 'Usage: $table->add(HASH or HASH_REF or CGI)'); + +# Checks that the FatherID exists and set the full name. + $p->{FatherID} ||= 0; + if ($p->{FatherID} =~ /\D/) { + my $sth = $self->select(ID => Full_Name => { Full_Name => $p->{FatherID} }); + if (my @row = $sth->fetchrow) { + $p->{FatherID} = $row[0]; + $p->{Full_Name} = "$row[1]/$p->{Name}"; + } + else { + my $names = $self->suggestions($p->{FatherID}); + return $self->warn( + @$names + ? (BADCATSUG => '
          ' . join('', map "
        • $_
        • ", @$names) . '
        ') + : (BADCATNAME => $p->{FatherId}) + ); + } + } + elsif ($p->{FatherID} != 0) { + my $full_name = $self->get_name_from_id($p->{FatherID}) or return $self->warn(BADCATID => $p->{FatherID}); + $p->{Full_Name} = "$full_name/$p->{Name}"; + } + else { + $p->{Full_Name} = $p->{Name}; + } + +# Checks that there is no other category with the same (Name, FatherID) + return $self->warn(CATEXISTS => $p->{Name}) + if $self->count({ Name => $p->{Name}, FatherID => $p->{FatherID} }); + + return 1; +} + +sub delete { +# ------------------------------------------------------------------- +# Deletes a category, but passes through the plugin system. +# + my ($self, $where) = @_; + if (not ref $where or ref $where eq 'ARRAY') { + $where = { ID => $where }; + } + return $self->fatal(BADARGS => 'Usage: $category->delete(condition)') + unless ref $where eq 'HASH' or UNIVERSAL::isa($where, 'GT::SQL::Condition'); + + my $ret; + my %cats = $self->select(qw/ID Direct_Links/ => $where)->fetchall_list; + if ($PLG->active_plugins('delete_category')) { + for my $id (keys %cats) { + my $r = $PLG->dispatch('delete_category', sub { return $self->SUPER::delete(@_) }, { ID => $id }); + $ret += $r if defined $r; + } + $ret = '0 but true' if (defined $ret and $ret == 0) or not keys %cats; + } + else { + $ret = $self->SUPER::delete($where); + } + + return $ret unless $ret; + +# Clear out the cache as the hierarchy has changed. + $self->_clear_cache; + + $ret; +} + +sub modify { +# ------------------------------------------------------------------- +# Modifies a category, but passes through the plugin system. +# + my ($self, $cat) = @_; + $PLG->dispatch('modify_category', sub { return $self->_plg_modify(@_) }, $cat); +} + +sub _plg_modify { +# ------------------------------------------------------------------- +# Modify a single category. +# + my $self = shift; + my $set = shift or return $self->error('BADARGS', 'FATAL', "Usage: \$cat->modify( { col => value ... } )."); + my $id = $set->{ID} or return $self->error('BADARGS', 'FATAL', "No primary key passed to modify!"); + +# Get the original info. + my $orig = $self->select(qw/ID FatherID Full_Name Name Number_of_Links/ => { ID => $id })->fetchrow_hashref + or return $self->warn(BADCATID => $id); + +# Fix up the father ID. + $set->{FatherID} ||= 0; + if ($set->{FatherID} !~ /^\d+$/) { + my $new_id = $self->get_id_from_name($set->{FatherID}); + if (! $new_id) { + my $names = $self->suggestions($set->{FatherID}); + return $self->error(@$names + ? ('BADCATSUG', 'WARN', "
          " . join('', map "
        • $_
        • ", @$names) . "
        ") + : ('BADCATNAME', 'WARN', $set->{FatherID}) + ); + } + $set->{FatherID} = $new_id; + } + + $self->can_modify($set, $orig) or return; + + if ($orig->{Name} eq $set->{Name} and $orig->{FatherID} == $set->{FatherID}) { + # Name and parent haven't changed, no special modify handling needed + return $self->SUPER::modify($set); + } + elsif ($orig->{FatherID} == $set->{FatherID}) { + # Name has changed, but parent is the same: update ancestors' + # timestamps, change the full name, and update subcategory names. + ($set->{Full_Name} = $orig->{Full_Name}) =~ s/\Q$orig->{Name}\E$/$set->{Name}/i; + my $ret = $self->SUPER::modify($set); + if ($ret) { + # Update was successful, update the timestamp of old and new parents + + # Clear the as the tree just changed + $self->_clear_cache; + + if ($set->{FatherID}) { + my $parents = $self->parents($id); + $self->update({ Timestmp => \"NOW()" }, { ID => $parents }, { GT_SQL_SKIP_CHECK => 1 }) + if @$parents; + } + + $self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name}); + } + + return $ret; + } + else { + # The category has moved; get the new parent's full name and update + my $fn = $self->select(Full_Name => { ID => $set->{FatherID} })->fetchrow; + $set->{Full_Name} = ($fn ? "$fn/" : '') . $set->{Name}; + + my $ret = $self->SUPER::modify($set); + if ($ret) { +# Clear the cache as the tree has changed. + $self->_clear_cache; + + $self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name}); + +# Now update counters on the above parents. +# Clear out the cache as otherwise we get our old parents. + if ($orig->{Number_of_Links} != 0) { + $self->link_count($orig->{FatherID}, -$orig->{Number_of_Links}); + $self->link_count($set->{FatherID}, $orig->{Number_of_Links}); + } + } +# Clear out the cache. + $self->_clear_cache; + return $ret; + } +} + +sub update_full_name { +# ----------------------------------------------------------------------------- +# Call this after changing a category's Full_Name to change all the category's +# children's full names. Call with the category ID, old full name, and new +# full name. +# + my ($self, $id, $old, $new) = @_; + + my @children = @{$self->children($id)}; + + my $new_escaped = $self->quote($new . '/'); + my $old_offset = length($old) + 2; + my $set; + if (lc $self->{connect}->{driver} eq 'mysql') { + $set = "CONCAT($new_escaped, SUBSTRING(Full_Name, $old_offset))"; + } + elsif (lc $self->{connect}->{driver} eq 'pg') { + $set = "$new_escaped || SUBSTRING(Full_Name, $old_offset)"; + } + elsif (lc $self->{connect}->{driver} eq 'odbc' or lc $self->{connect}->{driver} eq 'mssql') { + $set = "$new_escaped + SUBSTRING(Full_Name, $old_offset, 255)"; + } + elsif (lc $self->{connect}->{driver} eq 'oracle') { + $set = "$new_escaped || SUBSTR(Full_Name, $old_offset)"; + } + + if ($set) { + $self->update( + { Full_Name => \$set }, + { ID => \@children }, + { GT_SQL_SKIP_CHECK => 1 } + ); + } + else { + my $sth = $self->select(qw/ID Full_Name/ => { ID => \@children }); + while (my ($id, $full_name) = $sth->fetchrow) { + $full_name =~ s/^\Q$old/$new/ or next; + $self->update({ Full_Name => $full_name }, { ID => $id }, { GT_SQL_SKIP_CHECK => 1 }); + } + } +} + +sub can_modify { +# ------------------------------------------------------------------- +# Returns 1 if a record can be modified, undef otherwise. +# + my ($self, $new, $orig) = @_; + +# If the FatherID has changed, make sure the new father exists. If it's 0, then +# it's the root category and we don't worry about it. + if ($orig->{FatherID} != $new->{FatherID} or $orig->{Name} ne $new->{Name}) { + if ($orig->{FatherID} != $new->{FatherID} and $new->{FatherID}) { + $self->count({ ID => $new->{FatherID} }) or return $self->error('BADCATID', 'WARN', $new->{FatherID}); + } +# Now make sure the new FatherID,Name doesn't exist as it must be unique. + $self->count({ FatherID => $new->{FatherID}, Name => $new->{Name} }, GT::SQL::Condition->new(ID => '!=' => $orig->{ID})) and return $self->error('CATEXISTS', 'WARN', $new->{Name}); + } + return 1; +} + +sub template_set { +# ------------------------------------------------------------------- +# Return the value of template set to use for a given category. +# + my $self = shift; + my $id = shift or return $self->error('BADARGS', 'FATAL', "Must pass category id to template_set"); + return '' unless (exists $self->{schema}->{cols}->{Category_Template}); + + return $self->{_template_cache}->{$id} if (exists $self->{_template_cache}->{$id}); + +# If this category has a template set, use it. + my $cat_info = $self->select(Category_Template => { ID => $id })->fetchrow; + +# Otherwise look at its parents. + unless ($cat_info) { + my $parents = $self->parents($id); + for my $parent (@$parents) { + $cat_info = $self->select(Category_Template => { ID => $parent })->fetchrow + and last; + } + } + $self->{_template_cache}->{$id} = $cat_info || ''; + return $self->{_template_cache}->{$id}; +} + +sub parents { +# ----------------------------------------------------------------------------- +# Returns parent ID's given one or more category ID's. If called with a single +# category ID, the return value is an array reference of the ID's of the +# category's parents, from father => root. If called with an array reference +# of category ID's, the return value is a hash reference of +# (ID => [rootid ... parentid]) pairs, with one pair for each category. +# + my $self = shift; + my $id = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to parents"); + + my (%ret, @lookup); + for (ref $id ? @$id : $id) { + unless ($ret{$_} = $self->{_parent_cache}->{$_}) { + push @lookup, $_; + } + } + + if (@lookup) { + my $parents = $self->tree->parent_ids(id => \@lookup, include_dist => 1); + for (@lookup) { + $ret{$_} = $self->{_parent_cache}->{$_} = [sort { $parents->{$_}->{$b} <=> $parents->{$_}->{$a} } keys %{$parents->{$_}}]; + } + } + return ref $id + ? \%ret + : [reverse @{$ret{$id}}]; +} + +sub children { +# ----------------------------------------------------------------------------- +# Exactly like parents(), except you get descendants rather than ancestors, and +# you get them in shallowest => deepest. +# + my $self = shift; + my $id = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to children"); + + my (%ret, @lookup); + for (ref $id ? @$id : $id) { + unless ($ret{$_} = $self->{_child_cache}->{$_}) { + push @lookup, $_; + } + } + + if (@lookup) { + my $children = $self->tree->child_ids(id => \@lookup, include_dist => 1); + for (@lookup) { + $ret{$_} = $self->{_child_cache}->{$_} = [sort { $children->{$_}->{$a} <=> $children->{$_}->{$b} } keys %{$children->{$_}}]; + } + } + return ref $id + ? \%ret + : $ret{$id}; +} + +sub suggestions { +# ----------------------------------------------------------------------------- +# Returns a list of suggested category names. Takes a name and optional limit. +# + my $self = shift; + my $name = shift; + $name =~ y/\r\n//d; + $name =~ /\S/ or return []; + + $self->select_options('LIMIT 10'); + return [$self->select(Full_Name => GT::SQL::Condition->new(Full_Name => LIKE => "%$name%"))->fetchall_list]; +} + +sub link_count { +# ----------------------------------------------------------------------------- +# Change the Number_of_Links count by n for specified id, and all parents. You +# can pass multiple ID's by passing an array reference for ID. You can pass +# both multiple change values by passing a hash reference of (CHANGE => [ID, +# ...]) pairs as the ID (the change value passed to the function will be +# ignored). Note that Direct_Links counts are NOT changed. +# + my ($self, $id, $change) = @_; + + my %id; + if (!$id or ref $id eq 'ARRAY' and !@$id) { + return; + } + elsif (ref $id eq 'HASH') { + %id = %$id; + } + else { + %id = ($change => ref $id ? $id : [$id]); + } + + my %final; + while (my ($change, $id) = each %id) { + for (@$id) { + $final{$_} = ($final{$_} || 0) + $change; + } + my $parents = $self->tree->parent_ids(id => $id); + for my $parent (keys %$parents) { + for (@{$parents->{$parent}}) { + $final{$_} += $change; + } + } + } + + my %change; + for (keys %final) { + push @{$change{$final{$_}}}, $_; + } + + for (keys %change) { + $self->update( + { Number_of_Links => \('Number_of_Links' . ($_ > 0 ? ' + ' : ' - ') . abs) }, + { ID => $change{$_} }, + { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 } + ); + } +} + +sub changed { +# ------------------------------------------------------------------- +# Returns a statement handle that can be looped through to get a list +# of changed categories. +# + Links::init_date(); + + my $self = shift; + my $date = GT::Date::date_get(defined $_[0] ? $_[0] : time); + my $sth = $self->select(GT::SQL::Condition->new(Timestmp => '>=' => $date )); + return $sth; +} + +sub get_id_from_name { +# ------------------------------------------------------------------- +# Returns the category id based on the name. +# + my ($self, $name) = @_; + $name =~ y/\r\n//d; + $name =~ /\S/ or return; + + return $self->{_id_cache}->{$name} if exists $self->{_id_cache}->{$name}; + $self->{_id_cache}->{$name} = $self->select(ID => { Full_Name => $name })->fetchrow_array; + return $self->{_id_cache}->{$name}; +} + +sub get_name_from_id { +# ------------------------------------------------------------------- +# Returns the category full name based on the id. +# + my ($self, $id) = @_; + return $self->{_name_cache}->{$id} if exists $self->{_name_cache}->{$id}; + return $self->{_name_cache}->{$id} = $self->select(Full_Name => { ID => $id })->fetchrow; +} + + +sub as_url { +# ------------------------------------------------------------------- +# + my ($self, $name, $format) = @_; + return $PLG->dispatch('category_as_url', sub { return $self->_as_url(@_) }, $name, $format); +} + +sub _as_url { +# ------------------------------------------------------------------- +# Return the passed-in category name as a formatted category path, usable for +# static templates. +# + my ($self, $name, $format) = @_; + + my $cat = $self->select({ Full_Name => $name })->fetchrow_hashref + or return $name; + require Links::Tools; + $format ||= $IN->param('d') ? $CFG->{build_category_dynamic} ? "%$CFG->{build_category_dynamic}%" : '' : $CFG->{build_category_format}; + $format ||= '%Full_Name%'; + if ($format eq '%Full_Name%' and ($IN->param('d') or $CFG->{build_format_compat})) { + # Old Links SQL's (prior to configurable category naming) didn't + # coalesce multiple _'s into a single _, and dynamic mode still depends + # on that behaviour - so if the format is just Full_Name, mimic the old + # behaviour. + (my $ret = $cat->{Full_Name}) =~ y|a-zA-Z0-9_/-|_|c; + return $ret; + } + if ($format =~ /%Full_ID%/) { + $cat->{Full_ID} = join '/', (@{$self->tree->parent_ids(id => $cat->{ID})}, $cat->{ID}); + } + return Links::Tools::parse_format( + $format, + %$cat, + clean => 1 + ); +} + +sub set_new { +# ------------------------------------------------------------------- +# Sets the new flag for a given category id (or list). +# + my $self = shift; + my @ids = ref $_[0] eq 'ARRAY' ? @{shift()} : shift; + my $rel = $DB->table('Links', 'CatLinks', 'Category'); + for my $id (@ids) { + my $parents = $self->parents($id); + my @pids = reverse @$parents; + push @pids, $id; + + for my $pid (@pids) { + my $children = $self->children($pid); + $rel->select_options('GROUP BY Add_Date'); + my $sth = $rel->select(qw/MAX(Add_Date) isNew/ => GT::SQL::Condition->new( + CategoryID => '=' => [$pid, @$children], + VIEWABLE + )); + my ($newest, $new) = $sth->fetchrow; + $self->update( + { Has_New_Links => $new || 'No', Newest_Link => $newest }, + { ID => $pid }, + { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 } + ); + } + } +} + +sub _clear_cache { +# ------------------------------------------------------------------- +# Clear out cache results whenever a category is added/deleted/changed. +# + my $self = shift; + delete @$self{qw{_parent_cache _child_cache _name_cache _id_cache _template_cache}}; + return 1; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/ClickTrack.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/ClickTrack.pm new file mode 100644 index 0000000..a7e0daf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/ClickTrack.pm @@ -0,0 +1,41 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: ClickTrack.pm,v 1.3 2009/05/08 19:56:50 brewt 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. +# ================================================================== +# +# ClickTrack is subclassed so that new() is wrapped to handle ClickTrack table +# cleanups - but only the first time a ClickTrack table object is created, and +# only once / day. + +package Links::Table::ClickTrack; + +use strict; +use Links qw/$CFG %STASH/; +use GT::SQL::Table (); +use vars qw/@ISA/; +@ISA = 'GT::SQL::Table'; + +sub new { + my $self = shift->SUPER::new(@_) or return; + + return $self if $STASH{clicktrack_cleanup}++; + Links::init_date(); + my $cleanup_date = GT::Date::date_get(time - 2*24*60*60, '%yyyy%-%mm%-%dd%'); + return $self if $CFG->{last_clicktrack_cleanup} and $cleanup_date eq $CFG->{last_clicktrack_cleanup}; + + $self->delete(GT::SQL::Condition->new(Created => '<' => $cleanup_date)); + $CFG->{last_clicktrack_cleanup} = $cleanup_date; + $CFG->save; + + $self; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Links.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Links.pm new file mode 100644 index 0000000..60bc96b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Links.pm @@ -0,0 +1,630 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Links.pm,v 1.33 2009/05/11 05:57:45 brewt 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 Links::Table::Links; +# ================================================================== +use strict; +use Links qw/:payment :objects/; +use GT::SQL; +use GT::SQL::Table; +use vars qw /@ISA $DEBUG $ERRORS $ERROR_MESSAGE $CATLINK/; + +@ISA = qw/GT::SQL::Table/; +$DEBUG = 0; +$ERROR_MESSAGE = 'GT::SQL'; + +$ERRORS = { + NOCATEGORY => "You did not specify a category for this link.", + BADCATSUG => "There is no category with that name. Perhaps you meant: %s", + BADCATEGORY => "Invalid Category '%s', it does not exist.", +}; + +sub _query { +# ------------------------------------------------------------------- +# Overrides the default query to allow searching on category values. +# + my $self = shift; + my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => '$obj->insert(HASH or HASH_REF or CGI) only.'); + +# Parse date/time + if ($opts->{ExpiryDate} and $opts->{ExpiryDate} !~ /^\s*-?\d+\s*$/) { + my $converted = Links::date_to_time($opts->{ExpiryDate}); + $opts->{ExpiryDate} = $converted if defined $converted; + } + my $cat_id = $opts->{'CatLinks.CategoryID'} or return $self->SUPER::_query($opts); + $cat_id = $self->clean_category_ids($cat_id) or return; + +# Strip out values that are empty or blank (as query is generally +# derived from cgi input). + my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts; + $opts = \%input; + +# Create a CatLinks,Links table to do the search. + my $db = $DB->table('CatLinks','Links'); + +# Now start handling the search + my $cond = $self->build_query_cond($opts, $self->{schema}->{cols}); + if ( (ref $cond) =~ /::sth/i ) { + return $cond; + } + +# Set the limit clause, defaults to 25, set to -1 for none. + my $in = $self->_get_search_opts($opts); + my $offset = ($in->{nh} - 1) * $in->{mh}; + $db->select_options("ORDER BY $in->{sb} $in->{so}") if $in->{sb}; + $db->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1; + +# Add to the condition the category clause. + my $final = new GT::SQL::Condition; + $final->add($cond) if $cond; + $final->add('CatLinks.CategoryID', 'IN', $cat_id); + +# Now do the select. + my @sel; + push @sel, $final if $final; + push @sel, $opts->{rs} if $opts->{rs} and $final; + my $sth = $db->select(@sel) or return; + $self->{last_hits} = $db->hits; + return $sth; +} + +sub add { +# ------------------------------------------------------------------- +# Adds a link, but passes through Plugins::Dispatch. +# + my $self = shift; + my $p = (ref $_[0] eq 'HASH') ? shift : {@_}; + + $PLG->dispatch('add_link', sub { $self->_plg_add(@_) }, $p); +} + +sub _plg_add { +# ------------------------------------------------------------------- +# Add a link. +# + my ($self, $p) = @_; + +# Check to see if we can add a link, all errors get cascaded back. + $p->{'CatLinks.CategoryID'} or return $self->warn('NOCATEGORY'); + $p->{'CatLinks.CategoryID'} = $self->clean_category_ids($p->{'CatLinks.CategoryID'}) or return; + + $self->set_date_flags($p); + + my $counted = ($p->{isValidated} eq 'Yes' and $p->{ExpiryDate} >= time); + if ($p->{ExpiryDate} >= time) { + $p->{ExpiryCounted} = 0; + } + else { + $p->{ExpiryCounted} = 1; + } + +# Add the link, and return if there was an error, the error is propogated back. + my $id = $self->SUPER::add($p) or return; + +# Now add all the categories that the link belongs too. + my $cat = $DB->table('Category'); + my $cat_lnk = $DB->table('CatLinks'); + + my @cat_ids = ref $p->{'CatLinks.CategoryID'} ? @{$p->{'CatLinks.CategoryID'}} : $p->{'CatLinks.CategoryID'}; + my %parents; + +# Get a list of all the parents that this will affect. + foreach my $cat_id (@cat_ids) { + $cat_lnk->insert({ LinkID => $id, CategoryID => $cat_id }) or return; + if ($counted) { + for (@{$cat->parents($cat_id)}) { $parents{$_}++ } + $parents{$cat_id}++; + } + } + +# Now update those categories. + if ($counted) { + $cat->update( + { Newest_Link => $p->{Add_Date}, Has_New_Links => 'Yes', Number_of_Links => \"Number_of_Links + 1" }, + { ID => [keys %parents] }, + { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 } + ); + $cat->update({ Direct_Links => \"Direct_Links + 1" }, { ID => \@cat_ids }); + } + return $id; +} + +sub delete { +# ----------------------------------------------------------------------------- +# Deletes one or more links; there is a 'delete_link' hook below that can be +# used by plugins. +# + my ($self, $where) = @_; + if (not ref $where or ref $where eq 'ARRAY') { + $where = { ID => $where }; + } + return $self->fatal(BADARGS => 'Usage: $links->delete(condition)') + unless (ref $where eq 'HASH' and keys %$where) or (UNIVERSAL::isa($where, 'GT::SQL::Condition') and $where->sql); + + my $CatLinks = $DB->table('CatLinks'); + + # Sometimes { ID => x, CatLinks.CategoryID => y } gets passed in; it is + # wrong - CatLinks->delete should be used instead, which will recall this + # subroutine if any links need to be deleted. + if (ref $where eq 'HASH' and $where->{ID} and not ref $where->{ID} + and $where->{'CatLinks.CategoryID'} and not ref $where->{'CatLinks.CategoryID'}) { + return $CatLinks->delete({ LinkID => $where->{ID}, CategoryID => $where->{'CatLinks.CategoryID'} }); + } + + # Delete called with a normal condition + my $links = $self->select(qw/ID isValidated Add_Date ExpiryDate ExpiryCounted/ => $where)->fetchall_hashref; + @$links or return '0 but true'; + + my $new_cutoff = GT::Date::timelocal(0, 0, 0, (localtime time - $CFG->{build_new_cutoff})[3 .. 5]); + my (@counts, @new); + for (@$links) { + my $add_time = GT::Date::timelocal(GT::Date::parse_format($_->{Add_Date}, GT::Date::FORMAT_DATE)); + if ($_->{isValidated} eq 'Yes' and ($_->{ExpiryDate} >= time or not $_->{ExpiryCounted})) { + push @counts, $_->{ID}; + push @new, $_->{ID} if $add_time >= $new_cutoff; + } + } + + # Figure out how much each category needs to be decremented + $CatLinks->select_options("GROUP BY CategoryID"); + my %cats = $CatLinks->select(CategoryID => 'COUNT(*)' => { LinkID => \@counts })->fetchall_list; + + my %change; + while (my ($catid, $count) = each %cats) { + push @{$change{-$count}}, $catid; + } + + my $ret; + { + # CatLinks, which has an fk to Links.ID, needs to know what we're + # deleting so that it doesn't try to recall Links->delete + local @Links::Table::CatLinks::DELETING; + if ($PLG->active_plugins('delete_link')) { + for (@$links) { + @Links::Table::CatLinks::DELETING = $_->{ID}; + my $r = $PLG->dispatch('delete_link', sub { return $self->_plg_delete_link(@_) }, { ID => $_->{ID} }); + $ret += $r if defined $r; + } + $ret = '0 but true' if defined $ret and $ret == 0; + } + else { + # delete_link plugin hook isn't being used, a single delete will do it + my @lids = map $_->{ID}, @$links; + @Links::Table::CatLinks::DELETING = @lids; + $ret = $self->SUPER::delete({ ID => \@lids }); + } + } + + my $Category = $DB->table('Category'); + $Category->link_count(\%change); + + while (my ($change, $ids) = each %change) { + $Category->update({ Direct_Links => \("Direct_Links - " . abs $change) }, { ID => $ids }); + } + + $CatLinks->select_options("GROUP BY CategoryID"); + my @new_cats = $CatLinks->select(CategoryID => { LinkID => \@new })->fetchall_list; +# Now reset new flags on categories. + if ($ret and @new_cats) { + $Category->set_new(\@new_cats); + } + return $ret; +} + +sub _plg_delete_link { +# ----------------------------------------------------------------------------- +# Deletes a single link ID (plugin hook 'delete_link'. The second argument, +# $link, will, for historic reasons, always be a hash reference containing an +# 'ID' key, the value of which is the ID of the link to be deleted. +# + my ($self, $link) = @_; + my $link_id = $link->{ID}; + + return $self->SUPER::delete({ ID => $link_id }); +} + +sub modify { +# ------------------------------------------------------------------- +# Modifies a link, but passes through the plugin system. +# + my ($self, $link) = @_; + $PLG->dispatch('modify_link', sub { return $self->_plg_modify(@_) }, $link); +} + +sub _plg_modify { +# ------------------------------------------------------------------- +# Modify a single link. +# + my $self = shift; + my $set = shift or return $self->fatal(BADARGS => "Usage: \$cat->modify( { col => value ... } )."); + my $id = $set->{ID} or return $self->fatal(BADARGS => "No primary key passed to modify!"); + +# Let's set the changed date to right now. + Links::init_date(); + $set->{Mod_Date} = GT::Date::date_get(); + +# Force it to uncounted so that category counts will be properly updated + $set->{ExpiryCounted} = 0; + +# Check to see if we can modify (makes sure valid category id's were set). + $set->{'CatLinks.CategoryID'} or return $self->warn('NOCATEGORY'); + $set->{'CatLinks.CategoryID'} = $self->clean_category_ids($set->{'CatLinks.CategoryID'}) or return; + + $self->set_date_flags($set); + +# Check to see if we are changing from not validated => validated. + my ($old_validated, $old_expiry) = $self->select(qw/isValidated ExpiryDate/ => { ID => $set->{ID} })->fetchrow; + +# Check that the ExpiryDate is valid for the categories the link is in. + require Links::Payment; + my $expiry = (exists $set->{ExpiryDate} and $set->{ExpiryDate}) ? $set->{ExpiryDate} : $old_expiry; + $expiry = Links::Payment::check_expiry_date({ ExpiryDate => $expiry }, $set->{'CatLinks.CategoryID'}); + $set->{ExpiryDate} = $expiry if $expiry; + + my $new_validated = exists $set->{isValidated} ? $set->{isValidated} : $old_validated; + my $new_expiry = exists $set->{ExpiryDate} ? $set->{ExpiryDate} : $old_expiry; + + my $was_counted = $old_validated eq 'Yes' && $old_expiry >= time; + my $now_counted = $new_validated eq 'Yes' && $new_expiry >= time; + + if (exists $set->{ExpiryDate}) { + $set->{ExpiryCounted} = $set->{ExpiryDate} >= time ? 0 : 1; + } + +=for comment +Here are the various cases that the category count update code needs to handle and what to do in those cases: + +add the link to a new category + was counted, now_counted increment new cat + !was counted, now counted increment new cat + was counted, !now counted nothing + !was counted, !now counted nothing + +remove the link from a category + was counted, now_counted decrement old cat (CatLinks handles correctly) + !was counted, now counted nothing (CatLinks handles incorrectly and decrements in some cases, we fix and increment) + was counted, !now counted decrement old cat (CatLinks handles correctly) + !was counted, !now counted nothing (CatLinks handles correctly) + +no category changes + was counted, now_counted nothing + !was counted, now counted increment cats + was counted, !now counted decrement cats + !was counted, !now counted nothing + +the above combined (what the code needs to do) + was counted, now_counted increment new cats + !was counted, now counted increment curr cats, leave removed cats + was counted, !now counted decrement cats except removed and new cats (ie. decrement curr cats, except new cats) + !was counted, !now counted nothing +=cut + +# Do the update. + my $ret = $self->SUPER::modify($set); +# Check to see if the link has been moved into another category. + if ($ret) { + my $cat_lnk = $DB->table('CatLinks'); + my %orig_ids = map { $_ => 1 } $cat_lnk->select(CategoryID => { LinkID => $id })->fetchall_list; + my %cat_ids = map { $_ => 1 } ref $set->{'CatLinks.CategoryID'} ? @{$set->{'CatLinks.CategoryID'}} : $set->{'CatLinks.CategoryID'}; + +# Categories that the link has just been added to + my @new_cats = grep !$orig_ids{$_}, keys %cat_ids; +# Categories that the link has just been removed from + my @old_cats = grep !$cat_ids{$_}, keys %orig_ids; + + my %link_adjustment; + my $Category = $DB->table('Category'); + +# CatLinks doesn't update category counts on insert, so it's done further down in the code + if (@new_cats) { + $cat_lnk->insert_multiple([qw/LinkID CategoryID/], map [$id, $_], @new_cats); + } + +# However, deleting from CatLinks does result in updated category counts + if (@old_cats) { + $cat_lnk->delete({ LinkID => $id, CategoryID => \@old_cats }); + +# If the link has been modified from isValidated = No to Yes then the delete() +# from CatLinks will end up incorrectly decrementing the category count. If +# this is the case, then the count needs to increment to comphensate for this +# bug. This isn't !$was_counted && $now_counted because CatLinks delete +# currently does not take ExpiryDate into consideration. + push @{$link_adjustment{1}}, @old_cats if $old_validated eq 'No' and $new_validated eq 'Yes'; + } + +# The status hasn't changed: increment the new categories + if ($was_counted and $now_counted) { + push @{$link_adjustment{1}}, @new_cats if @new_cats; + } +# It wasn't viewable, but is now: increment all the current categories + elsif (not $was_counted and $now_counted) { + push @{$link_adjustment{1}}, keys %cat_ids; + } +# Was viewable, but now isn't: decrement all the current categories (except new ones) + elsif ($was_counted and not $now_counted) { +# Don't decrement counts on new categories, since the addition of the link +# never incremented the count in the first place + my %not_new = %cat_ids; + for (@new_cats) { + delete $not_new{$_}; + } + push @{$link_adjustment{-1}}, keys %not_new; + } +# Otherwise, it wasn't visible and still isn't, or it was visible but now +# isn't. In both cases, the new categories don't need to be incremented. + +# Actually adjust the link counts: + $Category->link_count(\%link_adjustment); + + while (my ($change, $ids) = each %link_adjustment) { + $Category->update({ Direct_Links => \("Direct_Links" . ($change > 0 ? ' + ' : ' - ') . abs $change) }, { ID => $ids }); + } + +# If this link is now validated this link, let's update category counters and new flags. +# It also needs to be updated if a link has been added to new categories. + if ((not $was_counted and $now_counted) or @new_cats) { + foreach my $cat (keys %cat_ids) { + my @cats = ($cat, @{$Category->parents($cat)}); + my $cond = GT::SQL::Condition->new(ID => '=', \@cats); + if ($set->{isNew} eq 'Yes') { + $Category->update({ Has_New_Links => 'Yes' }, $cond, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }); + } + $cond->add('Newest_Link', '<', $set->{Add_Date}); + $Category->update({ Newest_Link => $set->{Add_Date} }, $cond, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }); + } + } + +# Update the category timestamps to let people know that the page has changed. + $Category->update({ Timestmp => \"NOW()" }, { ID => [keys %cat_ids, @old_cats] }, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }); + } + return $ret; +} + +sub update { +# ------------------------------------------------------------------- +# Update a link. +# + my ($self, $set, $where) = @_; + + my $ret = $self->SUPER::update($set, $where); + +# Update the Category Timestmp of links which have certain columns updated + for (split(/\s*,\s*/, $CFG->{links_cols_update_category})) { + if (exists $set->{$_}) { + my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', $where)->fetchall_list; + $DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats }); + last; + } + } + return $ret; +} + +sub detailed_url { +# ----------------------------------------------------------------------------- +# Takes one or more link ID's, returns one or more parsed detailed URL/paths in +# the same order and position the links were passed in, NOT prefixed with +# build_detail_url/build_detail_path. If the ID passed in is actually a +# hashref, it is assumed that this hash ref includes a full set of Links and +# Category values for the link. +# + my ($self, @ids) = @_; + + my (@links, @sel_links, $need_select); + for (@ids) { + if (ref) { + push @links, $_; + push @sel_links, undef; + } + else { + push @links, undef; + push @sel_links, $_; + $need_select++; + } + } + + if ($need_select) { + my %links_cols = %{$self->cols}; + # Only select Category columns that don't conflict with Links columns. + my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols}; + + my $rel = $DB->table(qw/Links CatLinks Category/); + my %links = map { $_->{ID} => $_ } @{$rel->select( + 'Links.*', @cat_cols, 'CategoryID', { LinkID => [grep $_, @sel_links] } + )->fetchall_hashref}; + + for my $i (0 .. $#sel_links) { + $links[$i] = $links{$sel_links[$i]} if $sel_links[$i]; + } + } + + require Links::Tools; + my $format; + $format = $CFG->{build_detail_format} unless $IN->param('d'); + $format ||= '%ID%'; + $format .= '_%ID%' unless $format =~ /%ID%/; + my @ret = $PLG->dispatch('detailed_url', sub { + my ($format, @links) = @_; + my @ret; + for (@links) { + my $parsed; + if ($_) { +# Make Full_Name act the same for both category and detailed urls. Set +# build_format_compat = 2 if you want the < 3.3 behaviour of coalesced _'s for +# Full_Name. + if ($CFG->{build_format_compat} == 1) { + (my $fn = $_->{Full_Name}) =~ y|a-zA-Z0-9_/-|_|c; + $format =~ s/%Full_Name%/$fn/g; + } + + $parsed = Links::Tools::parse_format( + $format, + %$_, + clean => 1 + ); + $parsed =~ s{(^|[/\\])index$}{${1}_index}; + $parsed .= $CFG->{build_extension}; + } + push @ret, $parsed; + } + return @ret; + }, $format, @links); + return wantarray ? @ret : $ret[0]; +} + +sub category_detailed_url { +# ----------------------------------------------------------------------------- +# A wrapper to detailed_url which will return url's which given a category id, +# will only return url's which take the category into consideration. The only +# use for this is when a link is in multiple categories. +# + my ($self, $cat_id, @ids) = @_; + + my %links_cols = %{$self->cols}; +# Only select Category columns that don't conflict with Links columns. + my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols}; + + my @links; + my $rel = $DB->table(qw/Links CatLinks Category/); + for (@ids) { + push @links, $rel->select('Links.*', @cat_cols, 'CategoryID', { LinkID => $_, CategoryID => $cat_id })->fetchrow_hashref; + } + my @ret = $self->detailed_url(@links); + return wantarray ? @ret : $ret[0]; +} + +sub clean_category_ids { +# ------------------------------------------------------------------- +# Takes an argument which could be a list of category names or ids +# and returns an array ref of ids. +# + my ($self, $arg) = @_; + my $cat = $DB->table('Category'); + +# Fix up Category Names => Id numbers and offer suggestions +# if name was not found. + if (! ref $arg and $arg !~ /^\d*$/) { + my @cat_names = split /\n\r?/, $arg; + my @cat_ids = (); + foreach my $name (@cat_names) { + $name =~ s/[\r\n]//g; # Textareas have a nasty habit of putting \r's on the results. + my $id = ($name =~ /^\d+$/) ? $name : $cat->get_id_from_name($name); + if ($id) { + push(@cat_ids, $id); + } + else { + my $names = $cat->suggestions($name); + return $self->error(@$names + ? ('BADCATSUG', 'WARN', "
          " . join('', map "
        • $_
        • ", @$names) . "
        ") + : ('BADCATEGORY', 'WARN', $name) + ); + } + } + return \@cat_ids; + } +# We assume that if ID numbers are passed in, that they will +# be correct. This will get checked anyways by GT::SQL::Table, +# so no point doing it twice. + else { + my @ids = ref $arg ? @$arg : ($arg); + return \@ids; + } +} + +sub get_categories { +# ------------------------------------------------------------------- +# Takes a link id and returns a hash of category id => category name. +# + my $self = shift; + my $id = shift; + my $db = $DB->table('Category', 'CatLinks'); + my $sth = $db->select( { 'CatLinks.LinkID' => $id }, [ 'Category.ID', 'Category.Full_Name' ] ); + my %res = (); + while (my ($id, $name) = $sth->fetchrow_array) { + $res{$id} = $name; + } + return \%res; +} + +sub set_date_flags { +# ------------------------------------------------------------------- +# Takes a link hash ref and sets the date flags properly. +# + my ($self, $p) = @_; + + Links::init_date(); + my $today = GT::Date::date_get(); + if (GT::Date::date_diff($today, $p->{Add_Date}) <= $CFG->{build_new_cutoff}) { + $p->{isNew} = 'Yes'; + $p->{isChanged} = 'No'; + } + elsif (GT::Date::date_diff($today, $p->{Mod_Date}) <= $CFG->{build_new_cutoff}) { + $p->{isChanged} = 'Yes'; + $p->{isNew} = 'No'; + } + else { + $p->{isNew} = 'No'; + $p->{isChanged} = 'No'; + } + +# Possible ExpiryDate values that have to be handled here: +# -1 (unpaid link) - leave it as is, does not need to be converted +# \d (unixtime) - leave it as is, does not need to be converted +# >=\d (doesn't actually occur here, but in _query) - leave it as is, does not need to be converted +# YYYY-MM-DD +# YYYY/MM/DD +# YYYY/MM/DD HH::MM::SS +# The purpose of this bit of code is to convert any human readable dates into +# unixtime and leave everything else as is. + if ($p->{ExpiryDate} and $p->{ExpiryDate} !~ /^\s*-?\d+\s*$/) { + my $converted = Links::date_to_time($p->{ExpiryDate}); + $p->{ExpiryDate} = $converted if defined $converted; + } +} + +sub add_reviews { +# ------------------------------------------------------------------- +# Adds review information, but passes through the plugin system. +# + my ($self, $link) = @_; + $PLG->dispatch('add_reviews', sub { return $self->_plg_add_reviews(@_) }, $link); +} + +sub _plg_add_reviews { +# ------------------------------------------------------------------- +# Adds review information to an array ref of hash refs of links passed in +# in one query. +# + my $self = shift; + my $links = shift; + if (ref $links eq 'HASH') { + $links = [ $links ]; + } + my $review_db = $DB->table('Reviews'); + my @ids = map { $_->{ID} } @$links; + return unless (@ids); + + my $sth = $review_db->select({ Review_Validated => 'Yes' }, { Review_LinkID => \@ids }); + my %reviews; + my %review_count; + while (my $review = $sth->fetchrow_hashref) { + push @{$reviews{$review->{Review_LinkID}}}, $review; + $review_count{$review->{Review_LinkID}}++; + } + for my $link (@$links) { + $link->{Review_Count} = $review_count{$link->{ID}}; + $link->{Review_Loop} = $reviews{$link->{ID}}; + } + return $links; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Reviews.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Reviews.pm new file mode 100644 index 0000000..ff59242 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Reviews.pm @@ -0,0 +1,93 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Reviews.pm,v 1.1 2007/11/16 07:15:00 brewt Exp $ +# +# Copyright (c) 2007 Gossamer Threads Inc. All Rights Reserved. +# Redistribution in part or in whole strictly prohibited. Please +# see LICENSE file for full details. +# ================================================================== + +package Links::Table::Reviews; +# ================================================================== +use strict; +use Links qw/:objects/; +use GT::SQL; +use GT::SQL::Table; +use vars qw/@ISA $ERROR_MESSAGE/; + +@ISA = qw/GT::SQL::Table/; +$ERROR_MESSAGE = 'GT::SQL'; + +sub add { +# ----------------------------------------------------------------------------- +# Add a review. +# + my $self = shift; + my $rec = (ref $_[0] eq 'HASH') ? shift : { @_ }; + + my $id = $self->SUPER::add($rec) or return; + +# Update the link/category timestamp if the review is validated. + _update_timestamp($rec->{Review_LinkID}) if $rec->{Review_Validated} eq 'Yes'; + + $id; +} + +sub modify { +# ----------------------------------------------------------------------------- +# Modify a review. +# + my $self = shift; + my $set = shift or return $self->fatal(BADARGS => 'Usage: $reviews->modify({ col => value ... }).'); + my $id = $set->{ReviewID} or return $self->fatal(BADARGS => 'No primary key passed to modify!'); + + my ($old, $link_id) = $self->select('Review_Validated', 'Review_LinkID', { ReviewID => $id })->fetchrow; + + my $ret = $self->SUPER::modify($set) or return; + +# Only update the timestamp if it was unvalidated and still is - this is the +# only case where the pages shouldn't be rebuilt. + my $new = $set->{Review_Validated} || $old; + _update_timestamp($link_id) unless $old eq 'No' and $new eq 'No'; + + $ret; +} + +sub delete { +# ----------------------------------------------------------------------------- +# Delete one or more reviews. +# + my ($self, $cond) = @_; + ref $cond or return $self->fatal(BADARGS => '$reviews->delete(condition)'); + +# Get the link ids of the reviews that are about to be deleted and are +# validated (as only those pages need to be rebuilt). + my @link_ids = $self->select('Review_LinkID', $cond, { Review_Validated => 'Yes' })->fetchall_list; + + my $ret = $self->SUPER::delete($cond) or return; + + _update_timestamp(\@link_ids) if @link_ids; + + $ret; +} + +sub _update_timestamp { +# ----------------------------------------------------------------------------- +# Given a link ID (or an array ref if you want to update more than one link), +# update the Timestmp columns of the link as well as all the categories that +# the link is in. This ensures that these pages will be rebuilt on "Build +# Changed". +# + my $link_id = shift; + return unless $link_id; + + my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link_id })->fetchall_list; + $DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats }) if @cats; + $DB->table('Links')->update({ Timestmp => \'NOW()' }, { ID => $link_id }); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Users.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Users.pm new file mode 100644 index 0000000..b6d396a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Users.pm @@ -0,0 +1,162 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Users.pm,v 1.5 2005/05/12 20:51:24 brewt 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 Links::Table::Users; +# ================================================================== +use strict; +use GT::SQL; +use GT::SQL::Table; +use Links qw/$CFG $PLG/; +use vars qw/@ISA $ERRORS $ERROR_MESSAGE $AUTH/; + +@ISA = qw/GT::SQL::Table/; +$ERROR_MESSAGE = 'GT::SQL'; + +$ERRORS = { + AUTHERROR => "Authentication Error: %s", + INVALIDFORMAT => "Invalid format for username: %s" +}; + +sub init { +# ------------------------------------------------------------------- +# Load the authentication module. +# + require Links::Authenticate; + Links::Authenticate::auth('init', {}); + return 1; +} + + +sub add { +# ------------------------------------------------------------------- + my ($self, @args) = @_; + return $PLG->dispatch('add_user', sub { return $self->_plg_add(@_); }, @args ); +} + +sub _plg_add { +# ------------------------------------------------------------------- + init(); + my $self = shift; + my $p = ref $_[0] eq 'HASH' ? shift : {@_}; + + if (! Links::Authenticate::auth('valid_format', { Username => $p->{Username} })) { + $ERRORS->{INVALIDFORMAT} = Links::language('USER_INVALIDUSERNAME'); + return $self->error('INVALIDFORMAT', 'WARN', $p->{Username}); + } + + my $h = Links::Authenticate::auth('add_user', { Username => $p->{Username}, Password => $p->{Password} }); + unless ($h) { + $ERRORS->{AUTHERROR} = Links::language('USER_AUTHERROR'); + return $self->error('AUTHERROR', 'WARN', $Links::Authenticate::error); + } + + $p->{Username} = $h->{Username}; + $p->{Password} = $h->{Password}; + + return $self->SUPER::add($p); +} + +sub delete { +# ------------------------------------------------------------------- + my ($self, @args) = @_; + return $PLG->dispatch('delete_user', sub { return $self->_plg_delete(@_); }, @args ); +} + +sub _plg_delete { +# ------------------------------------------------------------------- + init(); + my ($self, $cond) = @_; + if (! ref $cond) { + $cond = { Username => $cond }; + } + my $count = 0; + my $link_db = $Links::DB->table('Links'); + my $sth = $self->select('Username', $cond); + while (my ($user) = $sth->fetchrow_array) { + my @links = $link_db->select('ID', { LinkOwner => $user })->fetchall_list; + for my $link_id (@links) { + $link_db->delete($link_id); + } + if (Links::Authenticate::auth('del_user', { Username => $user })) { + my $ret = $self->SUPER::delete($user); + $count++ if $ret; + } + } + return $count; +} + +sub modify { +# ------------------------------------------------------------------- + my ($self, @args) = @_; + return $PLG->dispatch('modify_user', sub { return $self->_plg_modify(@_); }, @args ); +} + +sub _plg_modify { +# ------------------------------------------------------------------- + init(); + my $self = shift; + my $input = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->insert(HASH or HASH_REF or CGI) only.'); + my $id = $input->{Username} or return $self->error("BADARGS", "FATAL", "No primary key passed to modify!"); + my $sth = $self->select('Username', 'Password', { Username => $id }); + my $rec = $sth->fetchrow_hashref; + if ($rec) { + if ($input->{Password} ne $rec->{Password}) { + Links::Authenticate::auth('change_pass', { Username => $rec->{Username}, Password => $rec->{Password}, New_Password => $input->{Password} }) + or return $self->error('AUTHERROR', 'WARN', $Links::Authenticate::error); + } + } + +# Connect to the database if we are not already connected + $self->connect; + +# Copy the data and remove anything that doesn't make sense here. + my $c = $self->{schema}->{cols}; + my $set = {}; + for (keys %$c) { + $set->{$_} = $input->{$_} if exists $input->{$_}; + } + +# Remove primary keys from update clause. + my $where; + if ($input->{orig_username}) { + $where->{Username} = $input->{orig_username}; + } + else { + foreach my $key (@{$self->{schema}->{pk}}) { + $where->{$key} = delete $set->{$key} if exists $set->{$key}; + } + } + return $self->error("NOPKTOMOD", "WARN") unless keys %$where == @{$self->{schema}->{pk}}; + +# Remove timestamps - no sense updating. + $self->_check_timestamp($where, $set) or return; + foreach my $col (keys %$c) { + delete $set->{$col} if $c->{$col}->{type} eq 'TIMESTAMP'; + } + +# Execute the update + $self->update($set, $where) or return; + return 1; +} + +sub random_pass { +# ------------------------------------------------------------------- +# Returns a random password. +# + my $self = shift; + my $pass = ''; + for (1 .. 8) { $pass .= chr(65 + int rand 57); } + return $pass; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Tools.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Tools.pm new file mode 100644 index 0000000..41a7c82 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Tools.pm @@ -0,0 +1,1736 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Tools.pm,v 1.198 2009/04/01 22:04:38 brewt 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 Links::Tools; +# ================================================================== +use strict; +use Links qw/:objects :payment/; +use Links::Payment qw/COMPLETED/; +use vars qw/%STATUS_OK %STATUS_BAD %STATUS_NEW $LANGUAGE/; + +%STATUS_OK = ( + -99, "Default URL (http://)", + 200, "OK 200", + 201, "CREATED 201", + 202, "Accepted 202", + 203, "Partial Information 203", + 302, "Found, but data resides under different URL (add a /)", + 301, "Found, but moved", + 303, "Method", +); + +%STATUS_BAD = ( + -1, "Could not lookup server", + -2, "Could not open socket", + -3, "Could not bind socket", + -4, "Could not connect", + -5, "Bad URL format", + -6, "Could not resolve host name", + -7, "ID could not be resolved", + -8, "Non parseable response", + 204, "No Response 204", + 304, "Not Modified", + 400, "Bad request", + 401, "Unauthorized", + 402, "PaymentRequired", + 403, "Forbidden", + 404, "File Not found", + 405, "Method Not Allowed", + 407, "Unknown Request Method", + 500, "Internal Error", + 501, "Not implemented", + 502, "Service temporarily overloaded", + 503, "Gateway timeout ", + 600, "Bad request", + 601, "Not implemented", + 602, "Connection failed (host not found?)", + 603, "Timed out" +); + +%STATUS_NEW = ( + 0, "New Link, UNCHECKED" +); + +sub search_log { +# ------------------------------------------------------------------ +# Display the keyword searches and perform purge if requested. +# + my $sl = $DB->table('SearchLogs'); + my $days = $IN->param('days'); + my %ret; + if (defined $days and $days =~ /^(?:\d+|\d*\.\d+)$/) { + my $cutoff = time - 86400 * $days; + $ret{num_logs_deleted} = $sl->delete(GT::SQL::Condition->new(slog_last => '<' => $cutoff)); + $ret{logs_deleted} = defined $ret{num_logs_deleted}; + } + + my $sb = $IN->param('sb'); + my $so = $IN->param('so'); + my $nh = $IN->param('nh') || 1; + my $mh = $IN->param('mh') || 25; + unless ($sb) { + $IN->param(sb => $sb = 'slog_count'); + $IN->param(so => $so = 'DESC'); + } + my $sth = $sl->query_sth($IN); + my $hits = $sl->hits; + my $toolbar = $DB->html($sl, $IN)->toolbar($nh, $mh, $hits, $IN->url); + my $logs = $sth->fetchall_hashref; + for (@$logs) { + if ($_->{slog_time}) { + my $f = int(3 - (log $_->{slog_time}) / log 10); + $f = 6 if $f > 6; + $f = 0 if $f < 0; + $_->{slog_time_formatted} = sprintf("%.${f}fs", $_->{slog_time}); + } + } + + return { + %ret, + log_loop => $logs, + toolbar => $toolbar, + cgi_url => $CFG->{db_cgi_url}, + sb => $sb, so => $so, nh => $nh, mh => $mh + } +} + +sub status { +# ------------------------------------------------------------------ +# Display the status of the links. +# + my $db = $DB->table('Links'); + $db->select_options( "GROUP BY Status" ); + my $sth = $db->select("Status", "COUNT(*)") or die "Query Error: $GT::SQL::error"; + my ($good, $bad, $all, $new, $status); + $good = $bad = $all = $new = 0; + while (my ($s, $c) = $sth->fetchrow_array) { + CASE: { + exists $STATUS_OK{$s} and $good += $c, last CASE; + exists $STATUS_BAD{$s} and $bad += $c, last CASE; + $new += $c; + }; + $all += $c; + $status->{$s} = $c; + } + my $out = ''; + my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; + foreach my $s (sort { $a <=> $b } keys %$status) { + $out .= qq!<$font>!; + CASE: { + exists $STATUS_OK{$s} and ($out .= qq!$status->{$s}<$font color="green">$STATUS_OK{$s}
        !), last CASE; + exists $STATUS_BAD{$s} and ($out .= qq!$status->{$s}<$font color="red">$STATUS_BAD{$s}
        !), last CASE; + exists $STATUS_NEW{$s} and ($out .= $status->{$s} . qq!<$font color="blue">$STATUS_NEW{$s}
        !), last CASE; + $out .= qq!$status->{$s}<$font color="red">Unknown Error Code: $s!; + } + } + if (! $out) { + $out = qq!0$STATUS_NEW{0}!; + } + return { Good => $good, Bad => $bad, All => $all, New => $new, Status => $out }; +} + +sub view_status { +# ------------------------------------------------------------------ +# Displays a page of links based on status in table format. +# + my $db = $DB->table('Links'); + my $vdb = $DB->table('Verify'); + my $args = $IN->get_hash; + +# First take care of any forced-validates. + if ($IN->param('validate')) { + foreach my $id ($IN->param('validate')) { + $vdb->delete( { LinkID => $id } ); + $vdb->add({ + LinkID => $id, + Status => 200, + Date_Checked => \'NOW()' + }); + $db->update( + { Status => 200 }, + { ID => $id } + ); + } + } + +# Now display the list of links. + my @status; + if ($IN->param('status') eq 'check_good') { + push @status, keys %STATUS_OK; + } + elsif ($IN->param('status') eq 'check_bad') { + push @status, keys %STATUS_BAD; + } + elsif ($IN->param('status') eq 'check_new') { + push @status, keys %STATUS_NEW; + } + elsif ($IN->param('status') eq 'check_all') { + push @status, keys %STATUS_BAD, keys %STATUS_OK, keys %STATUS_NEW; + } + else { + push @status, $IN->param('status'); + } + + @status or return { output => '', total => 0 }; + + my ($limit, $offset, $nh) = Links::limit_offset(); + + $db->select_options("ORDER BY Status, URL", "LIMIT $limit OFFSET $offset"); + my $sth = $db->select(qw/ID URL Title Status/, { Status => \@status }); + my $total = $db->hits; + my $old_status = ''; + my $out = ''; + + my $base_validate_link = "admin.cgi?do=page&page=tools_view_status.html&nh=$nh&mh=$limit"; + $base_validate_link .= join "", map "&status=$_", $IN->param("status"); + + while (my $link = $sth->fetchrow_hashref) { + if ($link->{Status} ne $old_status) { + my $name = $STATUS_OK{$link->{Status}} || $STATUS_BAD{$link->{Status}} || $STATUS_NEW{$link->{Status}}; + $out .= <$link->{Status} - $name
        +You can Delete all entries with this status or + Recheck all entries. + +HTML + $old_status = $link->{Status}; + } + $vdb->select_options("ORDER BY Date_Checked DESC", "LIMIT 10"); + my $sth2 = $vdb->select('Status', 'Date_Checked', { LinkID => $link->{ID} }); + my $history; + while (my $verify = $sth2->fetchrow_hashref) { + if ($STATUS_OK{$verify->{Status}}) { + $history .= qq~$verify->{Date_Checked} - $verify->{Status}
        ~; + } + elsif ($STATUS_BAD{$verify->{Status}}) { + $history .= qq~$verify->{Date_Checked} - $verify->{Status}
        ~; + } + else { + $history .= qq~$verify->{Date_Checked} - $verify->{Status}
        ~; + } + } + $history = "$history"; + + my $eURL = $IN->html_escape($link->{URL}); + my $eTitle = $IN->html_escape($link->{Title}); + + $out .= < + + + + + $link->{ID} - $eTitle - + [ + Modify + | Recheck + | Validate + ] + + + $history + +HTML + } + my $url = $IN->url; + my $html = $DB->html(['Links'], $IN); + my $toolbar = $html->toolbar($nh, $limit, $total, $url); + + return { output => $out, toolbar => $toolbar, total => $total }; +} + +sub check_duplicates { +# ------------------------------------------------------------------ +# Displays a list of duplicate URL's. +# + my $db = $DB->table('Links'); + my $nh = $IN->param('nh') || 1; + my $mh = $IN->param('mh') || 10; + my $begin = ($nh - 1) * $mh; + my $end = $begin + $mh; + +# We turn on big tables as this is usually a large query for MySQL. + if (lc $db->{connect}->{driver} eq 'mysql') { + my $sth = $db->prepare("SET OPTION SQL_BIG_TABLES = 1"); + $sth->execute; + } + +# Now get URL's and Counts. + $db->select_options("GROUP BY URL", "ORDER BY hits DESC"); + my $sth = $db->select('URL', 'COUNT(*) AS hits', GT::SQL::Condition->new('URL', '<>', "", 'URL', '<>', 'http://')); + my $row_num = -1; + my $total = 0; + my $dupes = ''; + my %seen; + while (my ($url, $count) = $sth->fetchrow_array) { + last if ($count == 1); + $total += $count; + $row_num++; + $seen{$url} = 1; + next if ($row_num < $begin); + last if ($row_num >= $end); + + my $eurl = $IN->html_escape($url); + my $sth2 = $db->select('ID', 'Title', { URL => $url }); + $dupes .= qq~ + + $eurl - $count + + ~; + while (my ($id, $title) = $sth2->fetchrow_array) { + my $cats = $db->get_categories($id); + my ($cid, $cname) = each %$cats; + my $etitle = $IN->html_escape($title); + + $dupes .= qq~ + + + + + $id - $etitle - $cname - + [ Modify ] + + + ~; + } + } + while (my ($url, $count) = $sth->fetchrow_array) { + last if ($count == 1); + $seen{$url} = 1; + $total += $count; + } + my $url = $IN->url; + my $html = $DB->html(['Links'], $IN); + my $hits = scalar keys %seen; + my $toolbar = $html->toolbar($nh, $mh, $hits, $url); + + return { total => $total, output => $dupes, toolbar => $toolbar, number_urls => $hits }; +} + +sub check_links { +# ------------------------------------------------------------------ +# Takes a list of Link IDs for checking and returns a hash ref +# of results (will also update the database) +# + my @ids = @_; + + my $links = $DB->table('Links'); + my %results; + +# Returns the integer http status of the link + my $check_func = sub { + my $link = shift; + my $status = link_status($link->{URL}); +# Let parent process know what's up + print "$link->{ID}\t$status\t$link->{URL}\n"; + return $status; + }; + + for my $id (@ids) { + my $sth = $links->select('ID', 'URL', { ID => $id }); +# With all the concurrent requests, some databases may limit the queries, so +# check to make sure the select was successful. + unless ($sth) { + warn "Error fetching link ($id): $GT::SQL::error"; + $results{$id} = undef; + next; + } + my $link = $sth->fetchrow_hashref; + unless ($link) { + warn "Error fetching link: no link with ID, $id, exists"; + $results{$id} = undef; + next; + } + $results{$id} = $PLG->dispatch('check_link', $check_func, $link); + } + + return \%results; +} + +sub link_status { +# ------------------------------------------------------------------ +# Returns an HTTP code on trying to reach the URL +# + my $url = shift or return; + $url =~ /^\w+\:.+/ or return; + if ($url =~ /^https?/i) { + return -99 if $url eq 'http://'; # The default url + return -5 unless $url =~ /https?\:\/\/[\w-]+\..+/i; + + require GT::WWW; + + my $www = new GT::WWW; + eval { + $www->url($url); + } or return -5; + + my $response; + eval { + local $SIG{ALRM} = sub { die "time out\n" }; + alarm(30); +# We're handling connection timeouts ourselves (GT::Socket sets an alarm, so we +# don't want it to set another alarm). + $www->connection_timeout(0); + $response = $www->head; + alarm(0); + }; + + if ($@ and $@ eq "time out\n") { + return -4; + } + +# Could not connect for some reason or the server returned an invalid response + return -4 unless $response; + +# If the HEAD request fails, attempt a GET request. On some misconfigured +# servers, a HEAD request will erroneously return a 4xx error. + unless ($response->status) { + # We don't care about the body of the page, so cancel the request + # as soon as we start getting the body: + $www->chunk_size(1); + $www->chunk(sub { $www->cancel }); + $response = $www->get; + } + + return -4 unless $response; + + return int $response->status; + } + elsif ($url =~ /^ftp/i) { + eval { require Net::FTP }; + + $@ and return; + + return unless $url =~ m,^ftp://(?:([^:]+):([^@]+)@)?([^/:]+):?(\d*)(.*)$,i; + + my ($user, $pass, $host, $port, $path) = ($1, $2, $3, $4, $5); + + $host or return -5; + gethostbyname($host) or return -6; + + $path ||= '/'; + $port ||= 21; + $user ||= 'anonymous'; + $pass ||= $CFG->{db_admin_email}; + + my $ftp = Net::FTP->new($host) or return -4; + $ftp->login($user, $pass) or return 401; + $ftp->mdtm($path) or return 404; + $ftp->quit; + + return 200; + } + else { + return 407; + } +} + +sub expired_links_purge { +# ------------------------------------------------------------------- +# Purge expired links . +# + if ($IN->param('expired_links_purge')) { + my $purge_days = $IN->param('purge_days'); + $purge_days = time - $purge_days * 24 * 60 * 60; + my $tb = $DB->table('Links'); + my $cond = new GT::SQL::Condition(ExpiryDate => '>' => UNPAID, ExpiryDate => '<' => $purge_days); + my $cnt = $tb->count($cond); + $cnt or return { error => 'No links to delete' }; + my $results = $tb->delete($cond); + return { del_num => $cnt, message => "$cnt expired links have been purged" }; + } + else { return } +} + +sub parse_format { +# ----------------------------------------------------------------------------- +# Takes a format and hash of x => value pairs, where x can be any combination +# of letters and numbers. +# +# Formats are as follows: +# %x% - the value - this may also be a pipe (|) separated list of possible keys +# to use as the value, where the first non-zero length value is used +# %20-15x% - if x is longer than 35 (20+15), this returns the first 20 +# characters followed by the last 15 characters +# %20x% - if x is longer than 20, this returns the first 20 +# %-20x% - if x is longer than 20, this returns the last 20 +# %20-15x/% - just like the versions above, except if the path contains /'s, +# the shortening applied to each part of the path, rather than the +# entire value. +# %20x/% - see %20-15x/% +# %-20x/% - see %20-15x/% +# +# Additionally, any of the formats above can be have (...) at the beginning - +# if present, instead of removing the excess values, the removed section will +# be replaced with whatever is inside the ( ). +# +# Using these rules, a pattern of '%(--)10-3Full_Name/%' would convert a +# 'Full_Name' value of: +# +# Long_Name_Category_1/Some_Other_Category_foo/another_cat_BAR +# +# into: +# +# Long_Name_--y_1/Some_Other--foo/another_cat_BAR +# +# Additionally, if a 'clean' key and value are passed in, path sanitization +# will be performed on the value. Specifically, any "." preceded by a "/" or +# "\", or at the beginning of the string, will be turned into "_". +# + my ($format, %opts) = @_; + + my $clean = delete $opts{clean}; + + for (keys %opts) { + length and not /\W/ or die "Invalid format parameter '$_': Only letters and numbers are permitted."; + $opts{$_} =~ y{A-Za-z0-9./-}{_}cs if $opts{$_}; + } + my $p = join '|', keys %opts; + $format =~ s{ + % + (?: + \(([\w.-]+)\) # leading (...) ($1) + )? + (?: + ( # Allows 10- and - in 10-10x and -10x ($2) + (\d+)? # ($3) + - + )? + (\d+) # allows 10 in 10x ($4) + )? + ((?:$p)(?:\|(?:$p))*) # The value to go here from %opts, above ($5) + (/)? # trailing / means that the numbers above get applied to each path component, instead of the whole thing ($6) + % + }{ + my $ellipsis = $1 || ''; + my ($begin, $end) = defined($2) ? ($3 || 0, $4) : ($4, 0); + my $val = $5; + my @vals = split(/\|/, $5); + for (@vals) { + if (exists $opts{$_} and defined $opts{$_} and length $opts{$_}) { + $val = $opts{$_}; + last; + } + } + # We only need to start chopping things up if $begin or $end is set + if ($begin or $end) { + my @components = $6 ? (split m{/}, $val, -1) : $val; + for (@components) { + if (length > ($begin + $end + length $ellipsis)) { + my $c = ''; + $c .= substr($_, 0, $begin) if $begin; + $c .= $ellipsis; + $c .= substr($_, -$end) if $end; + $_ = $c; + } + } + $val = join '/', @components; + } + $val + }egx; + + $format =~ s{(^|[/\\])\.}{${1}_}g if $clean; + $format; +} + +sub language_editor { +# ------------------------------------------------------------------ +# Loads the language file editor. +# + my $selected_dir = Links::template_set($IN->param('tpl_dir')); + + my $dir = "$CFG->{admin_root_path}/templates/$selected_dir"; + my $file = 'language.txt'; + my $lang = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 }); + my $font = 'face="Tahoma,Arial,Helvetica" size="2"'; + my $message; + if ($IN->param('save')) { + + if (-e "$dir/$file" and ! -w _) { + $message = "Unable to overwrite file: $file (permission denied). Please set permissions properly and save again."; + } + elsif (! -e _ and ! -w $dir) { + $message = "Unable to create new files in directory $selected_dir. Please set permissions properly and save again."; + } + else { + foreach my $code ($IN->param()) { + next unless ($code =~ /^save-(.*)/); + my $key = $1; + if ($IN->param("del-$key")) { + delete $lang->{$key}; + next; + } + my $orig = $IN->param("orig-$key"); + my $var = $IN->param($code); + next if $orig eq $var; + $var =~ s/\r?\n/\n/g; # Remove windows linefeeds. + $lang->{$key} = $var; + } + if (my $val = $IN->param('new') and my $var = $IN->param('new-val')) { + $var =~ s/\r?\n/\n/g; + $lang->{$val} = $var; + } + $lang->save; + $message = "Changes saved successfully."; + } + } + +# Reload the language file (you can't delete language from the inherited language.txt) + $lang = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 }); + +# Load the language file. + my $prefix = $IN->param('prefix'); + my %prefix_list; + my $table = ""; + foreach my $code (sort keys %$lang) { + if ($code =~ /^([^_]+)_/) { + $prefix_list{$1}++; + } + next if $prefix and $code !~ /^${prefix}_/; + my $str = $IN->html_escape($lang->{$code}); + $table .= qq~~; + } + $table .= qq~
        CodeDescriptionDelete
        $code
        New:  
        ~; + + my $prefix_output; + foreach my $prefix (sort keys %prefix_list) { + $prefix_output .= qq~ +$prefix ($prefix_list{$prefix}) |~; + } + chop $prefix_output if ($prefix_output); + + return { language_table => $table, message => $message, prefix_list => $prefix_output }; +} + +sub global_editor { +# ------------------------------------------------------------------ +# Loads the global template vars. +# + my $selected_dir = Links::template_set($IN->param('tpl_dir')); + + my $dir = "$CFG->{admin_root_path}/templates/$selected_dir"; + my $file = 'globals.txt'; + my $globals = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 }); + my $font = 'face="Tahoma,Arial,Helvetica" size="2"'; + my $message; + if ($IN->param('save')) { + + if (-e "$dir/$file" and ! -w _) { + $message = "Unable to overwrite file: $file (permission denied). Please set permissions properly and save again."; + } + elsif (! -e _ and ! -w $dir) { + $message = "Unable to create new files in directory $selected_dir. Please set permissions properly and save again."; + } + else { + my @param = $IN->param(); + foreach my $code (@param) { + next unless ($code =~ /^save-(.*)/); + my $key = $1; + if ($IN->param("del-$key")) { + delete $globals->{$key}; + next; + } + my $orig = $IN->param("orig-$key"); + my $var = $IN->param($code); + next if $orig eq $var; + $var =~ s/\r\n/\n/g; # Remove windows linefeeds. + $globals->{$key} = $var; + } + + my $val = $IN->param('new') || ''; + $val =~ s/^\s+//; + $val =~ s/\s+$//; + if (length $val) { + my $var = $IN->param('new-val'); + $var =~ s/\r\n/\n/g; + $globals->{$val} = $var; + } + + $globals->save; + $message = "Changes saved successfully."; + } + } + +# Reload the globals file (you can't delete globals from the inherited globals.txt) + $globals = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 }); + +# Load the globals file. + my $table = ""; + for my $code (sort keys %$globals) { + my $str = $IN->html_escape($globals->{$code}); + $table .= qq~~; + } + $table .= qq~
        CodeDescriptionDelete
        $code
        New:  
        ~; + + return { global_table => $table, message => $message }; +} + +sub template_editor { +# ------------------------------------------------------------------ +# Loads the template editor. +# + require GT::Template::Editor; + Links::init_date(); + my $demo = 0; + + my $editor = new GT::Template::Editor ( + root => $CFG->{admin_root_path} . '/templates', + # The template set/files dropdowns generated from this aren't used anymore, tpl_{dir,file}_select are used instead + default_dir => scalar Links::template_set(), + backup => 1, + cgi => $IN, + date_format => $CFG->{date_user_format} . ' %hh%:%mm%:%ss%', + skip_file => ['README', 'globals.txt', 'language.txt', '*.eml'], + demo => $demo + ); + return $editor->process; +} + +sub css_editor { +# ------------------------------------------------------------------ +# Provide admin CSS editor functionality +# + my %opts = @_; + + if (not $opts{css_dir} or $opts{css_dir} !~ /^[\w-]+$/) { + return { error => Links::language('CSSEDITOR_INVALID_TPL') }; + } + if (not $opts{css_file} or $opts{css_file} !~ /^[\w-]+\.css$/i) { + return { error => Links::language($opts{action} eq 'save' ? 'CSSEDITOR_INVALID_FILENAME' : 'CSSEDITOR_INVALID_CSS') }; + } + if ($opts{demo} and $opts{action} ne 'load') { + return { error => "You cannot $opts{action} files in the demo." }; + } + + my $css_path = "$CFG->{build_static_path}/$opts{css_dir}/$opts{css_file}"; + if ($opts{action} eq 'load') { + open CSS, $css_path or return { error => $! }; + my $css; + { + local $/; + $css = ; + } + close CSS; + return { css => $css }; + } + elsif ($opts{action} eq 'save') { + if (-e $css_path and -f _) { + require GT::File::Tools; + GT::File::Tools::copy($css_path, "$css_path.bak"); + } + open CSS, ">$css_path" or return { error => $! }; + print CSS $opts{css}; + close CSS; + } + elsif ($opts{action} eq 'delete') { + unlink $css_path or return { error => $! }; + } + return; +} + +sub template_dir_select { +# ------------------------------------------------------------------ +# Returns a select list of template directories. +# This function is deprecated (it does not support themes), use tpl_dir_select instead. +# + my ($dir, $file, @dirs); + ref $_[0] and shift; # Can be called from a template where first argument is a hash ref of tags. + my $selected_dir = shift || $CFG->{build_default_tpl} || 'luna'; + my $name = shift || 'tpl_dir'; + + $dir = $CFG->{admin_root_path} . "/templates"; + opendir TPL, $dir or die "unable to open directory: '$dir' ($!)"; + while (defined($file = readdir TPL)) { + push @dirs, $file unless + $file =~ /^\.\.?$/ or + $file eq 'admin' or $file eq 'browser' or $file eq 'help' or $file eq 'CVS' or + not -d "$dir/$file"; + } + closedir TPL; + + my $d_select_list = qq'"; + return $d_select_list; +} + +sub tpl_dir_select { +# ---------------------------------------------------------------------- +# Returns the template loop variable 'dir_select' with iteration value: +# directory - the name of the directory +# $mask is a regex of the templates that you don't wish to show +# $unmask is a regex of the templates that you only want to show +# $show_themes is whether or not to show themes in the template listing +# + my ($selected, $mask, $unmask, $show_themes) = @_; + if ($show_themes) { + $selected ||= join('.', Links::template_set($selected)); + } + else { + $selected ||= Links::template_set($selected); + } + + my @dirs; + my $dir = "$CFG->{admin_root_path}/templates"; + local *TPL; + opendir TPL, $dir or die "unable to open directory: '$dir' ($!)"; + for (sort { lc $a cmp lc $b } readdir TPL) { + next if $_ =~ /\./ or $_ eq 'CVS' or ($mask and m/^$mask$/i) or ($unmask and not m/^$unmask$/i) or not -d "$dir/$_"; + my $theme_found = 0; + if ($show_themes) { + my $themedir = "$CFG->{build_static_path}/$_"; + if (-d $themedir) { + opendir THEMES, $themedir or die "unable to open static directory: '$themedir' ($!)"; + while (my $theme = readdir THEMES) { + next if $theme !~ /.+\.css$/ or $theme =~ /_core\.css$/ or + not -f "$themedir/$theme"; + + $theme =~ s/\.css$//; + my %dir = (directory => $theme eq $_ ? $_ : "$_.$theme"); + $dir{dir_selected} = $dir{directory} eq $selected; + push @dirs, \%dir; + $theme_found++; + } + closedir THEMES; + } + } + + if (not $theme_found) { + push @dirs, { directory => $_, dir_selected => $_ eq $selected }; + } + } + closedir TPL; + + return { template_set_loop => \@dirs }; +} + +# Returns 0 or 1 - 1 means the template is okay. Takes full path, filename, and +# mask (optional) as arguments. +sub _is_template { + my ($dir, $file, $mask, $unmask) = @_; + return 0 if + substr($file, -4) eq '.bak' or + not -f "$dir/$file" or + not -r _ or + $file eq 'README' or $file eq 'language.txt' or $file eq 'globals.txt' or + ($mask and $file =~ /^$mask$/i) or ($unmask and $file !~ /^$unmask$/i); + return 1; +} + +sub tpl_file_select { +# ------------------------------------------------------------------------- +# Returns the template loop variable 'file_select' with iteration values: +# filename - the filename +# local - Indicates a 'local' file. +# If local set: new_local - Indicates a local file without a system file +# + my ($template, $mask, $unmask) = @_; + $template = Links::template_set($template) unless $template eq 'admin'; + + my $dir = "$CFG->{admin_root_path}/templates/$template"; + local *TPL; + my %files; + if (opendir TPL, "$dir/local") { + %files = map { _is_template("$dir/local", $_, $mask, $unmask) ? ($_ => 2) : () } readdir TPL; + closedir TPL; + } + opendir TPL, $dir or die "Unable to open directory '$dir': $!"; + for (readdir TPL) { + next unless _is_template($dir, $_, $mask, $unmask); + $files{$_}++; + } + closedir TPL; + + # %file now has keys of filenames, and values of: 1 => system, 2 => local, 3 => both + return { template_loop => [map +{ filename => $_, $files{$_} >= 2 ? (local => 1, new_local => $files{$_} == 3) : (local => 0) }, sort { lc $a cmp lc $b } keys %files] }; +} + +sub file_select { +# ------------------------------------------------------------------------- +# Returns a file_loop variable containing the files/directories in the directory +# that match the masks. +# +# $mask is a regex of the files/directories that you don't wish to show +# $unmask is a regex of the files/directories that you only want to show +# $type is either 'f' (show only files) or 'd' (show only directories) or empty +# (show both files and directories) +# + my ($dir, $mask, $unmask, $type) = @_; + + return { file_loop => [] } unless -d $dir; + + my @files; + opendir DIR, $dir or die "Unable to open directory '$dir': $!"; + for (sort { lc $a cmp lc $b } readdir DIR) { + next if ($mask and m/^$mask$/i) or ($unmask and not m/^$unmask$/i) or + ($type eq 'f' and not -f "$dir/$_") or ($type eq 'd' and not -d "$dir/$_"); + push @files, $_; + } + closedir DIR; + + return { file_loop => \@files }; +} + +sub editor_size { +# ------------------------------------------------------------------ +# Sets the editor default size. +# + my $editor_rows = $IN->param('cookie-editor_rows') || $IN->cookie('editor_rows') || 20; + my $editor_cols = $IN->param('cookie-editor_cols') || $IN->cookie('editor_cols') || 75; + return { editor_rows => $editor_rows, editor_cols => $editor_cols }; +} + +sub highlight { +# ------------------------------------------------------------------- +# + my ($str, $q) = @_; + (my $query = $q) =~ y/A-Z+"'-/a-z/d; + + my $i; + my %term; + for (split ' ', $query) { + my $lc = lc; + $term{$lc} = ($i++ % $CFG->{search_highlight_colors}) + 1 unless exists $term{$lc}; + } + return $str unless keys %term; + + my @pieces = split /((?:\s*<(?:[^>'"]|"[^"]*"|'[^']*')*>)+\s*|\s+)/, $str; + my $re = join '|', map quotemeta, keys %term; + for $i (0 .. int($#pieces / 2)) { + $pieces[2 * $i] =~ s{($re)}{$1}gi; + } + return join '', @pieces; +} + +sub validate_links { +# ------------------------------------------------------------------ +# Display a list of links waiting to be validated. +# + my $db = $DB->table('Links'); + my $cat_link = $DB->table('CatLinks'); + my $user_db = $DB->table('Users'); + my $html = $DB->html( $db, $IN ); + my $font = 'font face="Tahoma,Arial,Helvetica" size="1"'; + my $nh = $IN->param('nh') || 1; + my $mh = $IN->param('mh') || 5; + +# Process any actions. + my $results = _validate($db); + +# Clear our cgi so we don't cause conflicts. + $html->{input} = {}; + +# Get a list of links awaiting validation. + my $sth = $db->query_sth({ + isValidated => 'No', + mh => $mh, + nh => $nh, + sb => 'Add_Date', + so => 'DESC' + }); + my $total = $db->hits; + my $i = 0; + + my $output = ''; + Links::init_date(); + my $today = GT::Date::date_get(); + while (my $link = $sth->fetchrow_hashref) { + $i++; + my $user = $user_db->get($link->{LinkOwner}) || {}; + $link->{'CatLinks.CategoryID'} = [$cat_link->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list]; + +# Load reason before setting the Add_Date/Mod_Date to today. + my $reason = Links::send_email('link_rejected.eml', { %$user, %$link }, { get_body => 1 }); + +# Set Add_Date/Mod_Date, so if the link gets validated, it gets set to the current date. + $link->{Add_Date} = $today if $CFG->{link_validate_date}; + $link->{Mod_Date} = $today; + my $form = $html->form({ values => $link, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, file_field => 1, file_delete => 1 }); + + my $eURL = $IN->html_escape($link->{URL}); + + $output .= < + $form + + + + + + + + + + + +
        + <$font> + + + + + <$font> + + + (view | + check) + + + <$font> + + + + + <$font> + + + +
        + +
        + + +
        +HTML + } + my $toolbar; + if ($total > $mh) { + my $cgi = GT::CGI->new("do=page&page=tools_validate.html;nh=$nh;mh=$mh"); + $toolbar = $html->toolbar($nh, $mh, $total, $cgi->url); + } + return { output => $output, results => $results, total => $total, toolbar => $toolbar }; +} + +sub validate_changes { +# ------------------------------------------------------------------ +# Display a list of links waiting to be validated. +# + my $db = $DB->table('Links'); + my $chg_db = $DB->table('Changes'); + my $cat_link = $DB->table('CatLinks'); + my $user_db = $DB->table('Users'); + my $html = $DB->html($db, $IN); + my $font = 'font face="Tahoma,Arial,Helvetica" size="1"'; + my $nh = $IN->param('nh') || 1; + my $mh = $IN->param('mh') || 5; + +# Process any actions. + my $results = _validate($db); + +# Get a list of links awaiting validation. + my $sth = $chg_db->query_sth({ + LinkID => '*', + nh => $nh, + mh => $mh + }); + my $total = $chg_db->hits; + my $i = 0; + + my $output = ''; + while (my $link_data = $sth->fetchrow_hashref) { + $i++; + my $link = eval $link_data->{ChgRequest}; + +# Old Change requests may contain ExpiryDate, which can overwrite payments made +# by the user after making a modify request. Delete it so the ExpiryDate is +# pulled from the current link data. + delete $link->{ExpiryDate}; + +# Only the changed column data are saved in the Changes table + my $orig = $db->get($link->{ID}) || {}; + $link = { %$orig, %$link }; + +# Check that the ExpiryDate is valid for the categories the link is in + if ($CFG->{payment}->{enabled}) { + require Links::Payment; + my $expiry = Links::Payment::check_expiry_date($orig, $link->{'CatLinks.CategoryID'}); + $link->{ExpiryDate} = $expiry if $expiry; + } + + my $user = $user_db->get($link->{LinkOwner}) || {}; + foreach my $col (keys %{$db->{schema}->{cols}}) { + exists $link->{$col} or $link->{$col} = $db->{schema}->{cols}->{$col}->{default}; + } + $link->{$i . "-CatLinks.CategoryID"} = $link->{'CatLinks.CategoryID'}; + $link->{detailed_url} = "$CFG->{build_detail_url}/" . $db->detailed_url($link->{ID}); + my $form = $html->form({ values => $link, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, hide => ['Timestmp'], file_field => 1, file_delete => 1, file_use_path => 1, show_diff => 1 }); + +# Load reason. + my $reason = Links::send_email('link_rejected.eml', { %$user, %$link, modify => 1 }, { get_body => 1 }); + + my $eURL = $IN->html_escape($link->{URL}); + + $output .= < + $form + + + + + + + + + + + +
        + <$font> + + + + + <$font> + + + (view) + + + <$font> + + + + + <$font> + + + +
        + +
        + + +
        +HTML + } + my $toolbar; + if ($total > $mh) { + my $cgi = GT::CGI->new("do=page&page=tools_validate_changes.html;nh=$nh;mh=$mh"); + $toolbar = $html->toolbar($nh, $mh, $total, $cgi->url); + } + return { output => $output, results => $results, total => $total, toolbar => $toolbar }; +} + +sub validate_reviews { +# ------------------------------------------------------------------ +# Display a list of reviews waiting to be validated. +# + my $db = $DB->table('Reviews'); + my $user_db = $DB->table('Users'); + my $link_db = $DB->table('Links'); + my $html = $DB->html( $db, $IN ); + my $font = 'font face="Tahoma,Arial,Helvetica" size="1"'; + my $nh = $IN->param('nh') || 1; + my $mh = $IN->param('mh') || 5; + +# Process any actions. + my $results = _validate_review($db); + +# Clear our cgi so we don't cause conflicts. + $html->{input} = {}; + +# Get a list of links awaiting validation. + my $sth = $db->query_sth({ + Review_Validated => 'No', + mh => $mh, + nh => $nh, + sb => 'Review_Date', + so => 'DESC' + }); + my $total = $db->hits; + my $i = 0; + + my $output = ''; + while (my $review = $sth->fetchrow_hashref) { + $i++; + my $form = $html->form({ values => $review, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, file_field => 1, file_delete => 1 }); + +# Format the date + Links::init_date(); + $review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, '%yyyy%-%mm%-%dd%', $CFG->{date_user_format}); + + my $user = $user_db->get($review->{Review_Owner}) || {}; + my $link = $link_db->get($review->{Review_LinkID}) || {}; + $link->{detailed_url} = "$CFG->{build_detail_url}/" . $link_db->detailed_url($link->{ID}); + +# Load reason. + my $reason = Links::send_email('review_rejected.eml', { %$user, %$link, %$review }, { get_body => 1 }); + + $output .= < + $form + + + + + + + + + + + +
        + <$font> + + + + + <$font> + + + + + <$font> + + + + + <$font> + + + +
        + +
        + + +
        +HTML + } + my $toolbar; + if ($total > $mh) { + my $cgi = GT::CGI->new("do=page&page=tools_validate_reviews.html;nh=$nh;mh=$mh"); + $toolbar = $html->toolbar($nh, $mh, $total, $cgi->url); + } + return { output => $output, results => $results, total => $total, toolbar => $toolbar }; +} + +sub _validate_review { +# ------------------------------------------------------------------- +# Validate/delete/email review. +# + my $db = shift; + +# Let's parse out the form, and group our reviews together. + my $args = $IN->get_hash(); + my (@validate, @email, @delete, @modify, $tmp); + while (my ($key, $param) = each %$args) { + if ($key =~ /^validate-(\d+)/) { + push @validate, $1 if $param eq 'validate'; + push @email, $1 if $param eq 'email'; + push @delete, $1 if $param eq 'delete'; + } + elsif ($key =~ /^(\d+)-(.*)$/) { + $tmp->{$1}->{$2} = $param; + } + } + my $review = {}; + foreach (keys %$tmp) { + $review->{$tmp->{$_}->{ReviewID}} = $tmp->{$_}; + } + unless (@validate or @email or @delete ) { + return; + } + +# Now validate everyone. + my %error; + foreach my $id (@validate) { + my $res = $PLG->dispatch('validate_review', \&_validate_review_record, $review->{$id}); + if ($res) { $error{$id} = $res } + } + +# Delete records. + foreach my $id (@delete) { + $db->delete({ ReviewID => $id }) or $error{$id} = "
      • $id (Couldn't delete: $GT::SQL::error)"; + } + +# Delete and email records. + foreach my $id (@email) { + my $res = _delete_email_review_record($review->{$id}, $IN->param("reason-$id")); + if ($res) { $error{$id} = $res } + } + + my $results = join "", values %error; + return $results + ? "
          $results
        " + : "All Reviews successfully validated/deleted."; +} + +sub _validate_review_record { +# ------------------------------------------------------------------- +# Validates a record. +# + my $review = shift; + +# Update the database. + my $db = $DB->table('Reviews'); + $review->{Review_Validated} = 'Yes'; + + $db->modify($review) or return Links::language('VAL_GENERAL', $review->{ID}, $GT::SQL::error); + +# Add the link info to the fields. + my $link = $DB->table('Links')->get($review->{Review_LinkID}); + $link->{detailed_url} = "$CFG->{build_detail_url}/" . $DB->table('Links')->detailed_url($link->{ID}); + foreach my $key (keys %$link) { + exists $review->{$key} or $review->{$key} = $link->{$key}; + } + +# Add the user info to the fields. + my $user_db = $DB->table('Users'); + my $user_info = $user_db->get($review->{Review_Owner}); + foreach (keys %$user_info) { + $review->{$_} = $user_info->{$_} unless exists $review->{$_}; + } + +# Format the date + Links::init_date(); + $review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, '%yyyy%-%mm%-%dd%', $CFG->{date_user_format}); + +# Add anonymous reviewer + $review->{anonymous} = !$CFG->{user_review_required}; + + if ($CFG->{email_review_add}) { + my $email = $review->{Review_GuestEmail} || $review->{Email}; + unless ($email and $email =~ /^.+\@.+\..+$/) { + return Links::language('VAL_CANTEMAIL', 'No Review_GuestEmail or user Email address'); + } + + Links::send_email('review_added.eml', $review) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error); + } + return; +} + +sub _delete_email_review_record { +# ------------------------------------------------------------------- +# Delete and email a record. +# + my ($review, $reason) = @_; + my $db = $DB->table('Reviews'); + my $user_db = $DB->table('Users'); + +# Get the email address first. + my $user_info = $user_db->get($review->{Review_Owner}) || {}; + +# Delete the record. + my $res = $db->delete({ ReviewID => $review->{ReviewID} }); + + Links::send_email('review_rejected.eml', { %$user_info, %$review }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error); + return; +} + +sub _validate { +# ------------------------------------------------------------------- +# Validate/delete/email and links. +# + my $db = shift; + +# Let's parse out the form, and group our links together. + my $args = $IN->get_hash(); + my (@validate, @email, @delete, @modify, @delete_change, @email_change, $tmp); + while (my ($key, $param) = each %$args) { + if ($key =~ /^validate-(\d+)/) { + push @validate, $1 if $param eq 'validate'; + push @email, $1 if $param eq 'email'; + push @delete, $1 if $param eq 'delete'; + push @modify, $1 if $param eq 'modify'; + push @delete_change, $1 if $param eq 'deletechange'; + push @email_change, $1 if $param eq 'emailchange'; + } + if ($key =~ /^(\d+)-(.*)$/) { + $tmp->{$1}->{$2} = $param; + } + } + my $links = {}; + foreach (keys %$tmp) { + $links->{$tmp->{$_}->{ID}} = $tmp->{$_}; + } + unless (@validate or @email or @delete or @modify or @delete_change or @email_change) { + return; + } + +# Now validate everyone. + my $email_db = $DB->table('Users'); + my $chng_db = $DB->table('Changes'); + my %error; + foreach my $id (@validate) { + $links->{$id}->{_mode} = 'validate'; + my $res = $PLG->dispatch('validate_link', \&_validate_record, $links->{$id}); + $error{$id} = $res if $res; + } + +# Now modify everyone. + foreach my $id (@modify) { + $links->{$id}->{_mode} = 'modify'; + my $res = $PLG->dispatch('validate_link', \&_validate_record, $links->{$id}); + if ($res) { + $error{$id} = $res; + } + else { + $chng_db->delete({ LinkID => $id }); + } + } + +# Delete records. + foreach my $id (@delete) { + my $results = $PLG->dispatch('validate_delete', \&_delete_record, $db, $id); + $results or $error{$id} = "
      • $id (Couldn't delete: $GT::SQL::error)"; + } + +# Delete and email records. + foreach my $id (@email) { + my $res = $PLG->dispatch('validate_delete_email', \&_delete_email_record, $db, $email_db, $links->{$id}, $IN->param("reason-$id")); + $error{$id} = $res if $res; + } + +# Delete change requests + foreach my $id (@delete_change) { + my $results = $PLG->dispatch('validate_delete_change', \&_delete_change, $id); + $results or $error{$id} = "
      • $id (Couldn't delete: $GT::SQL::error)"; + } +# Delete and email change requests. + foreach my $id (@email_change) { + my $res = $PLG->dispatch('validate_delete_change_email', \&_delete_email_change_record, $db, $email_db, $links->{$id}, $IN->param("reason-$id")); + $error{$id} = $res if $res; + } + + my $results = join "", values %error; + return $results + ? "
          $results
        " + : "All Links successfully validated/deleted."; +} + +sub _validate_record { +# ------------------------------------------------------------------- +# Validates a record. +# + my $link = shift; +# Update the database. + my $type = $link->{_mode}; + my $db = $DB->table('Links'); + delete $link->{Timestmp} if ($type eq 'modify'); + $link->{isValidated} = 'Yes'; + +# Check the paths + my %fcols = $db->_file_cols(); + for ( keys %fcols ) { + require GT::SQL::File; + my $path = $link->{$_."_path"} or next; + $path =~ m,^$CFG->{admin_root_path}/tmp, or next; + $link->{$_} = GT::SQL::File->open($path); + } + +# Add back the extra time that it took the admin to validate the link. + if ($type ne 'modify' and $CFG->{payment}->{enabled} and exists $link->{ExpiryDate}) { + my $orig_expiry = $db->select(ExpiryDate => { ID => $link->{ID} })->fetchrow(); + my $new_expiry = Links::date_to_time($link->{ExpiryDate}) || $link->{ExpiryDate}; + +# We only add the extra time if the admin hasn't changed the expiry and the +# expiry is a real date + if ($new_expiry == $orig_expiry and $orig_expiry > 0 and $orig_expiry < UNLIMITED) { + my $payments = $DB->table('Payments'); + my $payment_time = $payments->select(payments_last => { + payments_linkid => $link->{ID}, + payments_status => COMPLETED + })->fetchrow(); + + if ($payment_time) { + my $lost_time = time - $payment_time; + $link->{ExpiryDate} = $orig_expiry + $lost_time; + } + } + } + + $db->modify($link) or return Links::language('VAL_GENERAL', $link->{ID}, $GT::SQL::error); + + for (keys %fcols) { + $link->{"${_}_path"} =~ m|^$CFG->{admin_root_path}/tmp/| + and _file_path_ok($link->{$_."_path"}) + and unlink $link->{$_."_path"}; + } + +# Add the user info to the fields. + my $user_db = $DB->table('Users'); + my $user_info = $user_db->get($link->{LinkOwner}) || {}; + for (keys %$user_info) { + $link->{$_} = $user_info->{$_} unless exists $link->{$_}; + } + +# Setup category tag, and Contact_Email, Contact_Name. + $link->{Category} = join "\n", values %{$db->get_categories($link->{ID})}; + + if (($type eq 'validate' and $CFG->{email_add}) or ($type eq 'modify' and $CFG->{email_mod})) { + my $email = $link->{Contact_Email} || $link->{Email}; + unless ($email and $email =~ /^.+\@.+\..+$/) { + return Links::language('VAL_CANTEMAIL', 'No Contact_Email or user Email address'); + } + + $link->{detailed_url} = "$CFG->{build_detail_url}/" . $db->detailed_url($link->{ID}); + + Links::send_email($type eq 'validate' ? 'link_added.eml' : 'link_modified.eml', $link) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error); + } + return; +} + +sub _delete_email_record { +# ------------------------------------------------------------------- +# Delete and email a record. +# + my ($db, $email_db, $link, $reason) = @_; + +# Get the email address first. + my $email = $email_db->get($link->{LinkOwner}, 'HASH') || {}; + +# Delete the record. + _delete_record($db, $link->{ID}) or return $GT::SQL::error; + + $link->{Category} = join "\n", values %{$db->get_categories($link->{ID})}; + Links::send_email('link_rejected.eml', { %$email, %$link }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error); + return; +} + +sub _delete_email_change_record { +# ------------------------------------------------------------------- +# Delete and email a change request. +# + my ($db, $email_db, $link, $reason) = @_; + +# Get the email address first. + my $email = $email_db->get($link->{LinkOwner}, 'HASH') || {}; + +# Delete the record. + _delete_change($link->{ID}) or return $GT::SQL::error; + + $link->{Category} = join "\n", values %{$db->get_categories($link->{ID})}; + Links::send_email('link_rejected.eml', { %$email, %$link, modify => 1 }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error); + return; +} + +sub _delete_record { +# ------------------------------------------------------------------- +# Deletes a link waiting to be validated, and the user that submitted it. +# + my ($db, $id) = @_; + my $link = $db->get($id, 'HASH', ['LinkOwner']); + $db->delete({ ID => $id }) or return Links::language('VAL_GENERAL', $id, $GT::SQL::error); + +# Remove the user if that's their only record and they were auto-setup. + if ($link) { + my $records = $db->count({ LinkOwner => $link->{LinkOwner}, Status => 'Not Validated' }); + if (!$records) { + my $user_db = $DB->table('Users'); + $user_db->delete({ Username => $link->{LinkOwner}, Status => 'Not Validated' }); + } + } + return 1; +} + +sub _delete_change { +# ------------------------------------------------------------------- +# Deletes a link waiting to be validated, and the user that submitted it. +# + my $id = shift; + my $db = $DB->table('Changes'); + my %fcols = $DB->table('Links')->_file_cols(); + my $href = $db->get({ LinkID => $id }) || {}; + $href = eval $href->{ChgRequest}; + + for (keys %fcols) { + my $fpath = $href->{$_}; + $fpath =~ m,^$CFG->{admin_root_path}/tmp/, and _file_path_ok($fpath) and unlink $fpath; + } + $db->delete({ LinkID => $id }); + + return 1; +} + +sub _file_path_ok { +# ------------------------------------------------------------------- + my $fpath = shift; + return $fpath !~ /\.\./ + and $fpath =~ /^[\w\\\/\-\.%]+$/ + and -e $fpath + and $fpath =~ m|^$CFG->{admin_root_path}/tmp/|; +} + +sub quick_links { +# ------------------------------------------------------------------- +# Add quick links to the admin menu. +# + my $name = $IN->param('name'); + my $url = $IN->param('url'); + my $manage = $IN->param('manage') || ''; + my @to_delete = $IN->param('remove'); + if ($IN->param('delete')) { + foreach my $url (@to_delete) { + delete $CFG->{quick_links}->{$url}; + } + $CFG->save; + } + + if ($name and $url) { + $CFG->{quick_links}->{$url} = $name; + $CFG->save; + } + my $output; + foreach my $url (sort { $CFG->{quick_links}->{$a} cmp $CFG->{quick_links}->{$b} } keys %{$CFG->{quick_links}}) { + $output .= qq~ ~ if $manage; + $output .= qq~  $CFG->{quick_links}->{$url}
        ~; + } + return { quick_links => $output } +} + +sub sql_monitor { +# ------------------------------------------------------------------- +# Runs queries. +# + my $query = $IN->param('query'); + my $file = $IN->param('saveto'); + my $style = $IN->param('style'); + my $table = $DB->table('Links'); + + if ($query) { + require GT::SQL::Monitor; + my $ran = GT::SQL::Monitor::query( + table => $table, + style => $style || 'tabs', + query => $query, + html => !$file + ); + + return $ran if $ran->{error}; + + if ($file) { + return { %$ran, error => 1, error_other => "The file '$file' already exists." } if -e $file; + local *FILE; + open FILE, "> $file" or return { %$ran, error => 1, error_other => "Unable to open file '$file': $!" }; + print FILE ${delete $ran->{results}}; + $ran->{results} = \"Results written to '$file'"; + } + return $ran; + } + + return { + db_prefix => $DB->prefix, + style => $style, + saveto => $file + }; +} + +sub remote_user { +# ------------------------------------------------------------------- +# Returns a remote_user environment variable. +# + my $user = $ENV{REMOTE_USER} or return ''; + $user eq '-' and return ''; # xitami sets it to '-', ugh. + return $user; +} + +sub auth_users { +# ----------------------------------------------------------------------------- +# Returns a htpasswd_users template loop variable of users in the .htpasswd +# file, and htpasswd_users_count of the number of users. +# + my $htpasswd = "$CFG->{admin_root_path}/.htpasswd"; + + local *HTPAS; + open HTPAS, "< $htpasswd" or die "Could not open '$htpasswd': $!"; + my @users = map { /^([^:]+):/ ? $1 : () } ; + close HTPAS; + + return { + htpasswd_users_count => scalar @users, + htpasswd_users => \@users + }; +} + +sub category_list { +# ------------------------------------------------------------------- +# Return a list of categories. If db_gen_category_list is 1 (basic, not +# treecats), then an array of all categories will be returned. If +# db_gen_category_list is 0, then only an array of the selected categories will +# be returned. +# + my %ret; + my @ids = $IN->param('CatLinks.CategoryID'); + @ids = $IN->param('ID') unless @ids; + + my $cat = $DB->table('Category'); + $cat->select_options('ORDER BY Full_Name'); + + if ($CFG->{db_gen_category_list} == 1) { + my $sth = $cat->select(); + my @cats; + while (my $c = $sth->fetchrow_hashref) { + for (0 .. $#ids) { + if ($c->{ID} == $ids[$_]) { + $c->{selected} = 1; + splice @ids, $_, 1; + last; + } + } + push @cats, $c; + } + $ret{category_loop} = \@cats; + $ret{category_loop_selected} = 0; + } + elsif ($CFG->{db_gen_category_list} == 0) { + $ret{category_loop} = @ids ? $cat->select({ ID => \@ids })->fetchall_hashref : []; + $ret{category_loop_selected} = 1; + } + return \%ret; +} + +sub category_list_html { +# ------------------------------------------------------------------- +# Return the html for a list of all the categories. Deprecated, use +# the above category_list instead! +# + my $category; + if ($CFG->{db_gen_category_list}) { + my $links = $DB->table('Links'); + my $html = $DB->html($links, $IN); + my @ids = $IN->param('CatLinks.CategoryID'); + @ids = $IN->param('ID') unless @ids; + $category = $html->get_all_categories(\@ids, 'CatLinks.CategoryID', 1); + } + else { + my $id = $IN->param('CatLinks.CategoryID') || $IN->param('ID'); + my $name = $DB->table('Category')->select('Full_Name', { ID => $id })->fetchrow; + if ($name) { + $category = qq|$name |; + } + else { + return; + } + } + return $category; +} + +sub category_list_selected { +# ------------------------------------------------------------------- +# Return a list of all the selected categories. Looping through a long list of +# categories in GT::Template can be slow, especially if you only need the +# selected ones. +# + my @ids = $IN->param('CatLinks.CategoryID'); + @ids = $IN->param('ID') unless @ids; + return unless @ids; + my $cat = $DB->table('Category'); + $cat->select_options("ORDER BY Full_Name"); + return $cat->select({ ID => \@ids })->fetchall_hashref; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Update.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Update.pm new file mode 100644 index 0000000..a39f40d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Update.pm @@ -0,0 +1,287 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Update.pm,v 1.11 2009/05/08 19:56:50 brewt 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 Links::Update; +use strict; +use Links qw/$CFG $IN %STASH/; +use GT::Update qw/:severity/; +use GT::File::Tools qw/basename/; +use GT::Config; +use constant CACHE_TIMEOUT => 5*60; # Only check the server at most once every 5 minutes + +sub _updater { + $STASH{updates} ||= GT::Config->load("$CFG->{admin_root_path}/Links/Config/Updates.pm", { debug => $CFG->{debug_level} }); + return $STASH{updater} if $STASH{updater}; + (my $cgi_path = $CFG->{admin_root_path}) =~ s{[\\/]+admin[\\/]*$}//; + $STASH{updater} = GT::Update->new( + product => 'Links', + version => $CFG->{version}, + reg_number => $CFG->{reg_number}, + init_path => $CFG->{admin_root_path}, + perl_path => $CFG->{path_to_perl}, + backup_path => "$CFG->{admin_root_path}/updates", + paths => { + script => { + cgi => $cgi_path, + admin => $CFG->{admin_root_path} + }, + library => $CFG->{admin_root_path}, + template => $CFG->{admin_root_path} . '/templates', + static => { + static => $CFG->{build_static_path}, + }, + fixed => { + static => $CFG->{build_static_path}, + cool => $CFG->{build_cool_path}, + detail => $CFG->{build_detail_path}, + new => $CFG->{build_new_path}, + ratings => $CFG->{build_ratings_path}, + build => $CFG->{build_root_path}, + }, + version => $CFG->{admin_root_path} + }, + replacements => { + library => { + '' => { + 'Links.pm' => { + '<%VERSION%>' => $CFG->{version} + } + } + } + }, + installed => ($STASH{updates}->{installed} ||= {}), + testing => $STASH{updates}->{testing} + ); +} + +sub check { + my $updater = _updater; + my ($cached, @updates); + if (my $cache = $STASH{updates}->{cache} and !$STASH{updates}->{testing}) { + if ($cache->{version} == $GT::Update::VERSION and $cache->{time} > time - CACHE_TIMEOUT) { # Only check at most once every 5 minutes + @updates = @{$cache->{updates}}; + $cached = 1; + } + } + unless ($cached) { + @updates = $updater->check; + + if (@updates == 1 and not defined $updates[0]) { + my $error = $updater->error; + my ($error_code, $error_message) = $error =~ /error code: (\d{3})\s*(.*)/; + return { error => $error, update_error_code => $error_code, update_error_message => $error_message }; + } + + $STASH{updates}->{cache} = { time => time, version => $GT::Update::VERSION, updates => \@updates }; + $STASH{updates}->save; + } + + my %ret; + my %available = map { $_->id => $_ } @updates; + for my $update (@updates) { + my $id = $update->id; + my $severity = $update->severity; + my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional'; + my $info = { + id => $id, + title => $update->title, + description => \($update->description), + severity => $severity, + files => [$update->files], + reversible => $update->reversible, + unique => $update->unique, + deps => [$update->deps], + revdeps => [$update->revdeps], + requires => [$update->requires], + deps_first => $update->deps_first, + update_type => $update_type, + installed => $update->installed + }; + push @{$ret{$update_type}}, $info; + $ret{update}->{$id} = $info; + } + for (sort { $a <=> $b } keys %{$STASH{updates}->{installed}->{$CFG->{version}}}) { + next if $available{$_}; + my %info = %{$STASH{updates}->{installed}->{$CFG->{version}}->{$_}}; + $info{id} = $_; + my $severity = $info{severity}; + my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional'; + push @{$ret{$update_type}}, \%info; + } + + for (qw/critical recommended optional version/) { + $ret{"${_}_total"} = @{$ret{$_} ||= []}; + $ret{"${_}_installed"} = $ret{"${_}_installable"} = 0; + for my $update (@{$ret{$_}}) { + next unless $available{$update->{id}}; + if ($available{$update->{id}}->{installed}) { + $ret{"${_}_installed"}++; + } + elsif (!$available{$update->{id}}->{impossible}) { + $ret{"${_}_installable"}++; + } + } + push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} }; + } + + my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } keys %{$STASH{updates}->{installed}}; + $ret{historic} = \@historic; + + \%ret; +} + +sub check_historic { + my $updater = _updater; + my $version = shift || $CFG->{version}; + + my @updates = $updater->check($version); + my %ret = (historic_version => $version, current_version => $CFG->{version}); + + for (@updates) { + my @files = $_->files; + my $severity = $_->severity; + my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional'; + my $id = $_->id; + my %info = ( + id => $id, + title => $_->title, + description => \($_->description), + severity => $severity, + files => \@files, + reversible => ($version eq $CFG->{version} ? $_->reversible : 0), + unique => $_->unique, + deps => [$_->deps], + revdeps => [$_->revdeps], + requires => [$_->requires], + revdeps_first => $_->revdeps_first, + update_type => $update_type, + installed => $_->installed + ); + push @{$ret{$update_type}}, \%info; + $ret{update}->{$id} = \%info; + } + + for (qw/critical recommended optional version/) { + push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} }; + } + + my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } grep keys %{$STASH{updates}->{installed}->{$_}}, keys %{$STASH{updates}->{installed}}; + $ret{historic} = \@historic; + + \%ret; +} + +# Takes a version such as 1.3.7 and converts it to 1.0307. +sub _numeric_version { + my @v = split /\./, (shift =~ /^(\d+(?:\.\d+)*)/)[0]; + my $numeric = 0; + for (0 .. $#v) { $numeric += $v[$_] * 100**-$_ } + $numeric; +} + +sub browser_install { + my @updates = $IN->param('install'); + my ($status, $errors) = install(@updates); + if (!$status) { + $errors->{updates_selected} = \@updates; + return $errors; + } + my %ret = (update_success => 1, update_status => $status, updates_selected => []); + + if ($status == 2) { + my $id = $errors; + my $path; + for (@{$STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{files}}) { + if (basename($_->{file}) eq 'install.cgi') { + $path = $_->{file} . "?upgrade_choice=Yes;install_dir=" . $IN->escape($CFG->{admin_root_path}); + last; + } + } + $ret{continue_url} = $path; + } + + return \%ret; +} + +# Installs updates passed in. Returns (0, \%error_hash) on failure, 1 on +# success of normal updates, (2, $id) on the success of version upgrade files. +sub install { + my @updates = @_; + my $updater = _updater; + my $v = $updater->verify(@updates); + return 0, { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH'; + @updates = @$v; + + my $success = $updater->install_verified(@updates); + if (!$success) { + my $error = $updater->error; + return 0, { update_failed => 1, error => "Update failed: $error" }; + } + $STASH{updates}->{installed} = { $updater->installed }; + delete $STASH{updates}->{cache}; + $STASH{updates}->save; + + if (@updates == 1 and $STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{severity} == VERSION) { + # We just installed a version upgrade + return (2, $updates[0]); + } + return 1; +} + +sub browser_uninstall { + my @updates = $IN->param('uninstall'); + my ($status, $errors) = uninstall(@updates); + if (!$status) { + $errors->{updates_selected} = \@updates; + return $errors; + } + return { uninstall_success => 1, updates_selected => [] }; +} + +sub uninstall { + my @updates = @_; + my $updater = _updater; + my $v = $updater->verify_uninstall(@updates); + return { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH'; + @updates = @$v; + + my $success = $updater->uninstall_verified(@updates); + if (!$success) { + my $error = $updater->error; + return 0, { uninstall_failed => 1, error => "Update uninstall failed: $error" }; + } + $STASH{updates}->{installed} = { $updater->installed }; + delete $STASH{updates}->{cache}; + $STASH{updates}->save; + + return 1; +} + +# Takes a string, such as '/foo/bar/blah/sdffffffddddddddddddddddddddddddddddd' +# and replaces a part of it with ... +# The arguments are: +# - string +# - number of characters before the ... +# - number of characters after the ... +sub shorten { + my ($string, $leading, $trailing) = @_; + if (length($string) <= ($leading + $trailing + 3)) { + return $string; + } + else { + return substr($string, 0, $leading) . ' ... ' . substr($string, -$trailing); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Upgrade.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Upgrade.pm new file mode 100644 index 0000000..c43d74f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Upgrade.pm @@ -0,0 +1,1034 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Upgrade.pm,v 1.50 2009/05/11 05:57:45 brewt Exp $ +# +# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +# Redistribution in part or in whole strictly prohibited. Please +# see LICENSE file for full details. +# ================================================================== +# + +package Links::Upgrade; + +use strict; +use vars qw/%VERSION_TREE @VERSION_HIDDEN/; +use Carp; +BEGIN { + # 1.01 below should be updated if this file depends on fixes/additions to GT::SQL::Upgrade + if (exists $INC{'GT/SQL/Upgrade.pm'} and $GT::SQL::Upgrade::VERSION < 1.01) { + delete $INC{'GT/SQL/Upgrade.pm'}; + } +} +use GT::SQL::Upgrade; + +# This has to be updated every release so that an upgrade can "walk" the tree +# to find any upgrade code. +%VERSION_TREE = ( + '2.0.0' => '2.0.1', + '2.0.1' => '2.0.2', + '2.0.2' => '2.0.3', + '2.0.3' => '2.0.4', + '2.0.4' => '2.0.5', + '2.0.5' => '2.1.0', + '2.1.0' => '2.1.1', + '2.1.1' => '2.1.2', + '2.1.2' => '2.2.0', + '2.2.0' => '2.2.1', + '2.2.1' => '2.99.0', + '2.99.0' => '2.99.1', + '2.99.1' => '3.0.0', + '3.0.0' => '3.0.1', + '3.0.1' => '3.0.2', + '3.0.2' => '3.0.3', + '3.0.3' => '3.0.4', + '3.0.4' => '3.1.0', + '3.1.0' => '3.2.0', + '3.2.0' => '3.3.0', +); + +# These versions won't show up in the available upgrade list returned by +# upgrades_available(). +@VERSION_HIDDEN = ('2.99.0', '2.99.1'); + +sub PERFORM ($$) { "\nPerforming " . (substr($_[0], 0, 1) == 2 ? "Links SQL" : "Gossamer Links") . " $_[0] -> $_[1] upgrades...\n" } +sub DONE ($$) { (substr($_[0], 0, 1) == 2 ? "Links SQL" : "Gossamer Links") . " $_[0] -> $_[1] upgrades performed.\n\n" } + +# In list context, returns a list of versions that are available to be upgraded +# from. In scalar context, returns a hash reference containing a +# upgrades_available key with a value of an array reference containing these +# versions (i.e. for use in a template). Only versions from %VERSION_TREE are +# included that actually have some upgrade code - in other words, 2.0.1 won't +# be includeded because there is no actual 2.0.1 upgrade code. +sub upgrades_available { + my %skip = map { $_ => 1 } @VERSION_HIDDEN; + my @avail = + map $_->[0], + sort { for my $i (1 .. (@$a > @$b ? @$a : @$b)) { my $c = $a->[$i] <=> $b->[$i]; return $c if $c } 0 } + map { ($skip{$_} or !__PACKAGE__->can_upgrade($_)) ? () : [$_, split /\./] } + keys %VERSION_TREE; + return wantarray ? @avail : { upgrades_available => \@avail }; +} + +# Usage: +# Links::Upgrade->upgrade( +# from => $version, # e.g. 2.2.1 +# output => $coderef, # code reference will be called with any output +# config => $config, # config object or hash reference (may be changed by upgrade code) +# ); +sub upgrade { + my $class = shift; + my %opts = @_; + for (qw/from config/) { + $opts{$_} or croak "Links::Upgrade->upgrade requires a '$_' option"; + } + + my ($version) = $opts{from} =~ /(\d+\.\d+\.\d+)/; + $version or croak "Invalid version passed to Links::Upgrade->upgrade: '$opts{from}'"; + + ref $opts{config} eq 'HASH' or UNIVERSAL::isa($opts{config}, 'GT::Config') or croak "Invalid 'config' value passed to Links::Upgrade->upgrade: '$opts{config}' not a hash reference or GT::Config object."; + not $opts{output} or ref $opts{output} eq 'CODE' or croak "Invalid 'output' value passed to Links::Upgrade->upgrade: '$opts{output}' not a code reference."; + $opts{output} ||= sub { print @_ }; + + my $safety; + while ($version) { + if (my $sub = $class->can_upgrade($version)) { + $sub->($opts{output}, $opts{config}); + } + $safety++ < 100 or croak "Internal upgrade error: $version => $VERSION_TREE{$version} appears to be recursing."; + } + continue { $version = $VERSION_TREE{$version} } + +# Walk the version upgrade tree + 1; +} + +# Takes a version, returns a code reference if the version -> next version +# upgrade code exists, undef otherwise. +sub can_upgrade { + my ($class, $from) = @_; + my $to = $VERSION_TREE{$from}; + for ($from, $to) { y/./_/ } + $class->can("upgrade__${from}__$to"); +} + +# Called from GT::Template with the version to upgrade from. Returns either an +# error tag or a message tag. +sub browser_upgrade { + my ($from, $stream) = @_; + $from and $from =~ /\d\.\d+\.\d/ or return { error => 'Invalid upgrade version entered.' }; + my $ret = ''; + __PACKAGE__->upgrade( + from => $from, + config => $Links::CFG, + output => sub { if ($stream) { print @_ } else { $ret .= join '', @_ } } + ); + + return { + upgrade_successful => 1, + upgrade_result => $ret + }; +} + +# Although not strictly upgrade-specific (you can force a tree rebuild) it is +# here as it is primarily an upgrade feature. +# Takes 2-3 arguments - an output subroutine, a GT::SQL object, and an optional +# force value - if specified and true, a rebuild will be forced. +sub create_cat_tree { + my ($out, $DB, $force) = @_; + $out ||= sub { print @_ }; + + require GT::SQL::Tree; + require GT::SQL::Tree::Rebuild; + my $t = $DB->table('Category'); + my %roots; + my $rebuild = GT::SQL::Tree::Rebuild->new( + table => $t, + order_by => 'Full_Name', # Ensure that parents come before children + cols => [qw/ID FatherID Full_Name/], + missing_root => sub { + my ($row, $table) = @_; + my ($id, $father) = @$row{qw/ID FatherID/}; + if (!$father) { + return $roots{$id} = 0; + } + my $root; + if (exists $roots{$father}) { + return $roots{$id} = $roots{$father} || $father; + } + else { + die "No parent category found for $row->{Full_Name}! Your Category table is corrupted."; + } + }, + missing_depth => sub { + my ($row, $table) = @_; + my $full_name = $row->{Full_Name}; + return $row->{Full_Name} =~ y|/||; + } + ); + + my $e = $DB->editor('Category'); + $out->("Adding Category tree...\n"); + my $ret = $e->add_tree(father => "FatherID", root => "CatRoot", depth => "CatDepth", force => $force ? 'force' : 'check', rebuild => $rebuild); + $out->($ret ? "\tOkay!\n" : "\tAn error occured: $GT::SQL::error\n"); + $ret; +} + +sub browser_cat_tree { + + my $stream = shift; + my $message; + my $okay = create_cat_tree(sub { if ($stream) { print @_ } else { for (@_) { $message .= $_ } } }, $Links::DB, 1); + return { browser_cat_tree_success => $okay, browser_cat_tree_message => $message }; +} + +sub upgrade__3_2_0__3_3_0 { +# --------------------------------------------------------------- +# Upgrade from 3.2.0 to 3.3.0 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.2.0' => '3.3.0'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + require GT::SQL::Table; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + require GT::Config; + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + +# Gossamer Links German fix + if ($cfg->{date_review_format} eq '%dd.%mm%.%yyyy% %HH%:%MM%') { + $cfg->{date_review_format} = '%dd%.%mm%.%yyyy% %HH%:%MM%'; + } + +# These options were split into two, so they should retain the same value as the original option + if ($cfg->{build_new_date_span_pages} ne $cfg->{build_span_pages}) { + $cfg->{build_new_date_span_pages} = $cfg->{build_span_pages}; + } + if ($cfg->{email_review_add} ne $cfg->{email_add}) { + $cfg->{email_review_add} = $cfg->{email_add}; + } + + $out->("Turning on build_format_compat...\n\tOkay!\n"); + $cfg->{build_format_compat} = 2; + +# Add new Reviews subclass + $out->("Adding Reviews subclass...\n"); + my $t = $DB->table('Reviews'); + $t->subclass( + table => { Reviews => "Links::Table::Reviews" } + ); + $t->save_state(); + $out->("\tOkay!\n"); + + $out->(DONE '3.2.0' => '3.3.0'); +} + +sub upgrade__3_1_0__3_2_0 { +# --------------------------------------------------------------- +# Upgrade from 3.1.0 to 3.2.0 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.1.0' => '3.2.0'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + require GT::SQL::Table; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + require GT::Config; + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + + $out->("Updating PayPal postback check...\n"); + for my $postback (@{$cfg->{payment}->{postback}}) { + next unless $postback->{method} eq 'PayPal'; + $postback->{var} = 'txn_type'; + last; + } + $out->("\tOkay!\n"); + + $out->("Updating review e-mail settings...\n"); + if ($cfg->{admin_email_review_add}) { + $cfg->{admin_email_review_add} = $cfg->{admin_email_add}; + } + if ($cfg->{admin_email_review_mod}) { + $cfg->{admin_email_review_mod} = $cfg->{admin_email_mod}; + } + $out->("\tOkay!\n"); + + $out->("Removing old browser templates from admin template set...\n"); + my $dir = "$cfg->{admin_root_path}/templates/admin"; + opendir TPL, $dir or die "Could not open '$dir': $!"; + while (defined(my $file = readdir TPL)) { + next unless -f "$dir/$file" and $file =~ /^browser.*\.html$/; + unlink "$dir/$file"; + } + $out->("\tOkay!\n"); + + add_column($out, $DB, Sessions => session_expires => { type => 'TINYINT', default => 1 }); + add_column($out, $DB, Reviews => Review_ModifyDate => { type => 'DATETIME', not_null => 1, default => '0000-00-00 00:00:00', form_display => $lang->{prompt_Review_ModifyDate} }); + alter_column($out, $DB, Reviews => Review_Date => { type => 'DATETIME', not_null => 1, form_display => $lang->{prompt_Review_Date} }); + + $out->(DONE '3.1.0' => '3.2.0'); +} + +sub upgrade__3_0_4__3_1_0 { +# ----------------------------------------------------------------------------- +# Upgrade from 3.0.4 to 3.0.5 + my ($out, $cfg) = @_; + + $out->(PERFORM '3.0.4' => '3.1.0'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + require GT::SQL::Table; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + require GT::Config; + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + + drop_index($out, $DB, CatLinks => 'catlnndx'); + + $out->("Scanning for and removing duplicate entries from CatLinks table...\n"); + # Do some hackery to get a non-subclassed CatLinks table + #my $catlinks = $DB->table('CatLinks'); + my $catlinks = GT::SQL::Table->new( + name => $DB->prefix . 'CatLinks', + connect => $DB->{connect}, + debug => $DB->{_debug}, + _err_pkg => 'GT::SQL::Table' + ); + $catlinks->select_options('GROUP BY LinkID, CategoryID', 'HAVING COUNT(*) > 1'); + my $sth = $catlinks->select(qw[LinkID CategoryID COUNT(*)]); + my $count; + while (my ($linkid, $catid) = $sth->fetchrow) { + my $deleted = $catlinks->delete({ LinkID => $linkid, CategoryID => $catid }); + $count += $deleted - 1; + $catlinks->insert({ LinkID => $linkid, CategoryID => $catid }); + } + $out->("\tOkay! " . ($count ? "$count duplicate entries found and removed.\n" : "No duplicate entries found.\n")); + + add_unique($out, $DB, CatLinks => { cl_cl_q => [qw/CategoryID LinkID/] }); + + + if ($cfg->{updates}) { + $out->("Moving update data from Links/Config/Data.pm to Links/Config/Updates.pm\n"); + my $cfg_updates = delete $cfg->{updates}; + require GT::Config; + my $updates = GT::Config->load("$cfg->{admin_root_path}/Links/Config/Updates.pm", { create_ok => 1 }); + for (keys %$cfg_updates) { + $updates->{$_} ||= $cfg_updates->{$_}; + } + $updates->save; + $out->("\tOkay!\n"); + } + + add_column($out, $DB, Links => LinkExpired => { type => 'INT', form_display => $lang->{prompt_LinkExpired}, form_type => 'hidden' }); + add_index($out, $DB, Category => { c_p => ['Payment_Mode'] }); + + $out->(DONE '3.0.4' => '3.1.0'); +} + +sub upgrade__3_0_3__3_0_4 { +# --------------------------------------------------------------- +# Upgrade from 3.0.3 to 3.0.4 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.0.3' => '3.0.4'); + $out->(DONE '3.0.3' => '3.0.4'); +} + +sub upgrade__3_0_2__3_0_3 { +# --------------------------------------------------------------- +# Upgrade from 3.0.2 to 3.0.3 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.0.2' => '3.0.3'); + $out->(DONE '3.0.2' => '3.0.3'); +} + +sub upgrade__3_0_1__3_0_2 { +# --------------------------------------------------------------- +# Upgrade from 3.0.1 to 3.0.2 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.0.1' => '3.0.2'); + $out->(DONE '3.0.1' => '3.0.2'); +} + +sub upgrade__3_0_0__3_0_1 { +# --------------------------------------------------------------- +# Upgrade from 3.0.0 to 3.0.1 +# + my ($out, $cfg) = @_; + $out->(PERFORM '3.0.0' => '3.0.1'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + + recreate_table($out, $DB, 'MailingListIndex', sub { my $table = shift; my $cols = $table->cols; $cols->{Name}->{type} eq 'TEXT' }, + cols => [ + ID => { type => 'INT', unsigned => 1, not_null => 1 }, + Name => { type => 'CHAR', size => 255, not_null => 1 }, + DateModified => { type => 'INT', not_null => 1 }, + DateCreated => { type => 'INT', not_null => 1 } + ], + pk => 'ID', + ai => 'ID' + ); + + if (-e(my $oldconfig = "$cfg->{admin_root_path}/Links/ConfigData.pm")) { + $out->("Removing old Links/ConfigData.pm file (has been replaced with Links/Config/Data.pm)...\n"); + require GT::File::Tools; + my $ret = GT::File::Tools::move($oldconfig, "$oldconfig.old"); + $out->($ret ? "\tOkay!\n" : "\tAn error occured: $!\n"); + } + + $out->(DONE '3.0.0' => '3.0.1'); +} + +sub upgrade__2_99_1__3_0_0 { +# ----------------------------------------------------------------------------- +# Placeholders that currently just prints a 2.2.1 -> 3.0.0 success message. If +# a 2.99.1 is released, this will become 2_99_1__3_0_0 and so on. This allows +# transparent handling of the beta versions without duplicating any code and +# without needing to mention the beta in the upgrade output. +# + my ($out, $cfg) = @_; + + $out->("Updating build_static_path, _url...\n"); + $cfg->{build_static_path} ||= "$cfg->{build_root_path}/static"; + $cfg->{build_static_url} ||= "$cfg->{build_root_url}/static"; + $out->("\tOkay!\n"); + + $out->(DONE '2.2.1' => '3.0.0'); +} + +sub upgrade__2_99_0__2_99_1 { +# --------------------------------------------------------------- +# Upgrade from 2.99.0 to 2.99.1 +# + my ($out, $cfg) = @_; + import lib $cfg->{admin_root_path}; + require GT::Config; + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + + require GT::SQL; + $Links::DB = my $DB = GT::SQL->new("$cfg->{admin_root_path}/defs"); + +# Drop unnecessary Bookmark columns added to the Users table in 2.99.0 + my $usercols = $DB->table('Users')->cols; + for (qw/FolderSortField FolderSortOrd/) { + drop_column($out, $DB, 'Users', $_) if exists $usercols->{$_}; + } + + delete $cfg->{bookmark_folder_sort}; + delete $cfg->{bookmark_folder_sort_order}; + delete $cfg->{bookmark_user_sort}; + delete $cfg->{bookmark_user_sort_order}; + +# Don't print here - the final 2.99.x -> 3.0.0 code prints the final message. + 1; +} + +sub upgrade__2_2_1__2_99_0 { +# --------------------------------------------------------------- +# Upgrade from 2.2.1 to 2.99.0 +# + my ($out, $cfg) = @_; + $out->(PERFORM '2.2.1' => '3.0.0'); + import lib $cfg->{admin_root_path}; + require GT::Config; + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + + require GT::SQL; + $Links::DB = my $DB = GT::SQL->new("$cfg->{admin_root_path}/defs"); + $Links::STASH{clicktrack_cleanup} = 1; + $Links::STASH{expired_links} = 1; + + require Links::Plugins; + require GT::Plugins::Manager; + my $plugin = GT::Config->load("$cfg->{admin_root_path}/Plugins/plugin.cfg", { create_ok => 1 }); + { + package FakeCGI; + sub param { $_[0]->{$_[1]} } + } + + add_column($out, $DB, Category => CatRoot => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' }); + add_column($out, $DB, Category => CatDepth => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' }); + add_column($out, $DB, Category => Direct_Links => { type => 'INT', not_null => 1, default => 0, form_display => $lang->{prompt_Direct_Links} }); + + create_cat_tree($out, $DB); + + my $t = $DB->table('Category'); + $out->("Updating Category fk to reference itself...\n"); + my $ret = $t->fk(Category => { FatherID => 'ID' }); + $out->($ret ? "\tOkay!\n" : "\tAn error occured: $GT::SQL::error\n"); + + $out->("Updating CatLinks subclass...\n"); + $t = $DB->table('CatLinks'); + $t->subclass( + table => { CatLinks => "Links::Table::CatLinks" } + ); + $t->save_state(); + $out->("\tOkay!\n"); + + $out->("Updating ClickTrack subclass...\n"); + $t = $DB->table('ClickTrack'); + $t->subclass( + table => { ClickTrack => "Links::Table::ClickTrack" } + ); + $t->save_state(); + $out->("\tOkay!\n"); + + $out->("Updating Direct_Links values...\n"); + my $rel = $DB->table(qw/CatLinks Links/); + $rel->select_options("GROUP BY CategoryID"); + my $where = GT::SQL::Condition->new(isValidated => '=' => 'Yes'); + $where->add(ExpiryDate => '>=' => time) if $cfg->{payment}->{enabled}; + my %catlinks = $rel->select(qw/CategoryID COUNT(ID)/ => $where)->fetchall_list; + $t = $DB->table('Category'); + for (keys %catlinks) { + $t->update({ Direct_Links => $catlinks{$_} }, { ID => $_ }, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }); + } + $out->("\tOkay!\n"); + + if ($plugin and exists $plugin->{Bookmark}) { + my $bcfg = Links::Plugins::get_plugin_user_cfg('Bookmark'); + $out->("Bookmark plugin detected, importing Bookmark settings...\n"); + $out->("\tImporting Bookmark configuration...\n"); + for (keys %$bcfg) { + $cfg->{"bookmark_$_"} = $bcfg->{$_}; + } + $out->("\t\tDone!\n"); + + $out->("\tUninstalling Bookmark plugin...\n"); + my $fakein = bless { plugin_name => "Bookmark", skip_uninstall => 1 }, "FakeCGI"; + my $man = new GT::Plugins::Manager(cgi => $fakein, plugin_dir => "$cfg->{admin_root_path}/Plugins"); + $ret = $man->uninstall; + $out->($ret->{error} ? "\t\tAn error occured: $ret->{error}\n" : "\t\tDone!\n"); + } + + add_table($out, $DB, 'Bookmark_Folders', + cols => [ + my_folder_id => { type => 'INT', not_null => 1, unsigned => 1 }, + my_folder_name => { type => 'VARCHAR', not_null => 1, size => 255 }, + my_folder_description => { type => 'VARCHAR', size => 255 }, + my_folder_user_username_fk => { type => 'VARCHAR', size => 50 }, + my_folder_default => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 }, + my_folder_public => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 } + ], + pk => 'my_folder_id', + ai => 'my_folder_id', + fk => { + Users => { my_folder_user_username_fk => 'Username' } + } + ); + + add_table($out, $DB, 'Bookmark_Links', + cols => [ + my_id => { type => 'INT', not_null => 1, unsigned => 1 }, + my_link_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + my_user_username_fk => { type => 'VARCHAR', size => 50 }, + my_folder_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + my_comment => { type => 'VARCHAR', size => '255' } + ], + pk => 'my_id', + ai => 'my_id', + fk => { + Users => { my_user_username_fk => 'Username' }, + Bookmark_Folders => { my_folder_id_fk => 'my_folder_id' }, + Links => { my_link_id_fk => 'ID' }, + } + ); + +# Commented out columns were removed in 2.99.1 +# add_column($out, $DB, Users => FolderSortField => { type => 'VARCHAR', size => 255, not_null => 1, regex => '^[\s\w]+$', default => 'my_folder_name', form_display => $lang->{prompt_FolderSortField} }); +# add_column($out, $DB, Users => FolderSortOrd => { type => 'ENUM', values => ['ASC', 'DESC'], not_null => 1, default => 'ASC', form_display => $lang->{prompt_FolderSortOrd} }); + add_column($out, $DB, Users => SortField => { type => 'VARCHAR', size => 255, not_null => 1, regex => '^[\s\w]+$', default => 'Title', form_display => $lang->{prompt_SortField} }); + add_column($out, $DB, Users => SortOrd => { type => 'ENUM', values => ['ASC', 'DESC'], not_null => 1, default => 'ASC', form_display => $lang->{prompt_SortOrd} }); + add_column($out, $DB, Users => PerPage => { type => 'INT', not_null => 1, unsigned => 1, default => 15, form_display => $lang->{prompt_PerPage} }); + add_column($out, $DB, Users => Grouping => { type => 'TINYINT', not_null => 1, unsigned => 1, default => 0, form_display => $lang->{prompt_Grouping} }); + + add_column($out, $DB, Editors => CanModReview => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' }); + +# Integrate the user's email template changes into the new templates + $out->("Upgrading email templates...\n"); + require GT::File::Tools; + require GT::Mail; + require GT::Mail::Parse; + my %files = ( + 'email-add.txt' => { + new_name => 'link_added.eml', + subject => 'VAL_APPROVESUB', + }, + 'email-del.txt' => { + new_name => 'link_rejected.eml', + subject => 'VAL_REJECTSUB', + }, + 'email-mod.txt' => { + new_name => 'link_modified.eml', + subject => 'VAL_APPROVECHGSUB', + }, + 'email-notify.txt' => { + new_name => 'link_expiry_notify.eml', + subject => 'LINKS_NOTIFY_SUBJECT', + }, + 'email-expired.txt' => { + new_name => 'link_expired.eml', + subject => 'LINKS_NOTIFY_SUBJECT', + }, + 'email-password.txt' => { + new_name => 'password.eml', + subject => 'USER_LOSTPASSSUB', + }, + 'email-validate.txt' => { + new_name => 'validate.eml', + subject => 'USER_VALEMAILSUB', + }, + 'review-email-add.txt' => { + new_name => 'review_added.eml', + subject => 'REVIEW_VAL_APPROVESUB', + }, + 'review-email-del.txt' => { + new_name => 'review_rejected.eml', + subject => 'VAL_REJECTSUB', + } + ); + my $new_template = 'luna'; + my $template_path = "$cfg->{admin_root_path}/templates"; + my $fh = \do { local *FH; *FH }; + opendir $fh, $template_path or die "Could not open '$template_path': $!"; + while (my $template_set = readdir $fh) { + next if $template_set =~ /^\./ or $template_set eq 'admin' or $template_set eq $new_template + or $template_set =~ /_php$/ or $template_set =~ /^lang_.*\./ or not -d "$template_path/$template_set" + or $template_set eq 'browser' or $template_set eq 'CVS'; + $out->("\tUpgrading $template_set template set...\n"); + my $l = GT::Template::Inheritance->get_path(file => "language.txt", path => "$template_path/$template_set", use_local => 1, use_inheritance => 1); + unless (-e $l) { + $out->("\t\t(no language.txt found, not a template set?)\n"); + next; + } + my $clang = GT::Config->load($l); + for my $file (keys %files) { + if (not -e "$template_path/$template_set/$files{$file}->{new_name}" and -e "$template_path/$new_template/$files{$file}->{new_name}") { + GT::File::Tools::copy("$template_path/$new_template/$files{$file}->{new_name}", "$template_path/$template_set/$files{$file}->{new_name}"); + } + next unless -e "$template_path/$template_set/local/$file" and -r _ and not -e "$template_path/$template_set/local/$files{$file}->{new_name}"; + $out->("\t\tCreating $files{$file}->{new_name} from $file... "); + open BODY, "$template_path/$template_set/local/$file" or die "Couldn't open template $template_path/$template_set/local/$file: $!"; + my $body; + { + local $/; + $body = ; + } + close BODY; + + next unless -e "$template_path/$new_template/$files{$file}->{new_name}"; + my $top = GT::Mail::Parse->new( + in_file => "$template_path/$new_template/$files{$file}->{new_name}", + crlf => "\n", + headers_intact => 0 + )->parse(); + + $top->body_data($body) if $body; + $top->set(Subject => $clang->{$files{$file}->{subject}}) if $clang->{$files{$file}->{subject}}; + + if ($body or $clang->{$files{$file}->{subject}}) { + my $mail = new GT::Mail; + $mail->top_part($top); + $mail->write("$template_path/$template_set/local/$files{$file}->{new_name}"); + } + $out->("done!\n"); +# We could also delete the subject language keys and the old email templates, +# but it's better we leave them around than delete something they might not +# want to lose or if something else is still using them. + } + $out->("\t\tOkay!\n"); + } + closedir $fh; + $out->("\tOkay!\n"); + + if (delete $cfg->{foreign_char}) { + $cfg->{build_category_format} = '%Full_ID%'; + $cfg->{build_category_dynamic} = 'ID'; + } + elsif (my $f = delete $cfg->{build_directory_field}) { + $cfg->{build_category_format} = $f ? "%$f%" : ''; + $cfg->{build_category_dynamic} = $f; + } + + add_table($out, $DB, 'SearchLogs', + cols => [ + slog_query => { type => 'VARCHAR', not_null => 1, size => 255 }, + slog_count => { type => 'INT', not_null => 1, default => 0 }, + slog_hits => { type => 'INT', not_null => 1, default => 0 }, + slog_time => { type => 'FLOAT' }, + slog_last => { type => 'INT', not_null => 1, default => 0 }, + ], + pk => 'slog_query' + ); + + if ($plugin and exists $plugin->{SearchLogger} and $DB->table('SearchLog')) { + $out->("SearchLogger plugin detected, importing SearchLogger settings...\n"); + my $old = $DB->table('SearchLog'); + my $new = $DB->table('SearchLogs'); + require GT::Date; + $out->("\tTransferring old search logs...\n"); + my $sth = $old->select(qw/Term HitCount Results Last_Hit/); + my $i; + if ($sth) { + while (my $row = $sth->fetchrow_hashref) { + $i++; + my %slog_row = ( + slog_query => $row->{Term}, + slog_count => $row->{HitCount}, + slog_hits => $row->{Results}, + slog_time => undef + ); + my @time; + if ($row->{Last_Hit} =~ /^(\d{4}-\d\d-\d\d ( ?)\d?\d:\d\d:\d\d)/) { + @time = GT::Date::parse_format($1, "%yyyy%-%mm%-%dd% $2%H%:%MM%:%ss%"); + } + elsif ($row->{Last_Hit} =~ /^(\d{4}-\d\d-\d\d)/) { + @time = GT::Date::parse_format($1, '%yyyy%-%mm%-%dd%'); + } + $slog_row{slog_last} = @time ? GT::Date::timelocal(@time) : 0; + $ret = $new->insert(\%slog_row); + $out->("\t\tAn error occured: $GT::SQL::error\n") unless $ret; + } + $out->("\t\t$i rows imported.\n"); + } + else { + $out->("\t\tAn error occured: $GT::SQL::error\n"); + } + + $out->("\tDropping SearchLog table...\n"); + my $e = $DB->editor('SearchLog'); + my $ret = $e->drop_table; + $out->($ret ? "\t\tOkay!\n" : "\t\tAn error occured: $GT::SQL::error\n"); + + $out->("\tUninstalling SearchLogger plugin...\n"); + my $fakein = bless { plugin_name => "SearchLogger", skip_uninstall => 1 }, "FakeCGI"; + my $man = new GT::Plugins::Manager(cgi => $fakein, plugin_dir => "$cfg->{admin_root_path}/Plugins"); + $ret = $man->uninstall; + $out->("\t\tOkay!\n"); + } + + add_table($out, $DB, 'NewsletterSubscription', + cols => [ + UserID => { type => 'CHAR', size => 50 }, + CategoryID => { type => 'INT', not_null => 1 }, + ], + unique => { + ns_uc => ['UserID', 'CategoryID'] + }, + fk => { + Users => { UserID => 'Username' }, + Category => { CategoryID => 'ID' } + } + ); + + if (exists $DB->table('Users')->cols->{Newsletter}) { + $out->("Importing User Newsletter settings...\n"); + my $sth = $DB->table('Users')->select('Username', { Newsletter => 'Yes' }); + my $ns = $DB->table('NewsletterSubscription'); + if ($sth) { + while (my $user = $sth->fetchrow) { + $ns->insert({ UserID => $user, CategoryID => 0 }); + } + $out->("\tOkay!\n"); + } + else { + $out->("\tAn error occured: $GT::SQL::error\n"); + } + + drop_column($out, $DB, 'Users', 'Newsletter'); + } + +# Don't print here - the final 2.99.x -> 3.0.0 code prints the final message. +# $out->("Links SQL 2.2.1 -> 3.0.0 upgrades performed.\n"); + 1; +} + +sub upgrade__2_2_0__2_2_1 { +# --------------------------------------------------------------- +# Upgrade from 2.2.0 to 2.2.1 +# + my ($out, $cfg) = @_; + $out->(PERFORM '2.2.0' => '2.2.1'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + $Links::STASH{expired_links} = 1; + + require GT::Config; + my $lang = GT::Config->load($cfg->{admin_root_path} . '/templates/admin/language.txt'); + +# Update Rating regex + alter_column($out, $DB, Links => Rating => { type => 'DECIMAL', precision => 4, scale => 2, not_null => 1, default => 0, regex => '^(?:10(?:\.0*)?|\d(?:\.\d*)?)$', form_display => $lang->{prompt_Rating} }); + +# Update payments_term from CHAR(8) to CHAR(10) + alter_column($out, $DB, Payments => payments_term => { type => 'CHAR', not_null => 1, size => 10 }); + +# Fix fk_tables that might have been deleted due to the SQL database overwrite bug + my %fk_tables = ( + Category => [qw/CatPrice CatLinks CatRelations Editors/], + Links => [qw/Payments Changes Reviews CatLinks Verify/], + Payments => [qw/PaymentLogs/], + Users => [qw/Links Changes Reviews Editors Sessions/] + ); + $out->("Checking fk_tables...\n"); + my $p = $DB->prefix; + while (my ($table, $tables) = each %fk_tables) { + my $tb = $DB->table($table); + my $changed; + for (@$tables) { + $tb->_add_fk_table("$p$_") and $changed++; + } + if ($changed) { + $tb->save_state; + $out->("\t\t$table table's fk_tables repaired\n"); + } + } + $out->("\tOkay!\n"); + + $out->(DONE '2.2.0' => '2.2.1'); +} + +sub upgrade__2_1_2__2_2_0 { +# --------------------------------------------------------------- +# Upgrade from 2.1.2 to 2.2.0 +# + my ($out, $cfg) = @_; + $out->(PERFORM '2.1.2' => '2.2.0'); + + import lib $cfg->{admin_root_path}; + require GT::Config; + + # Check to see that the PPC plugin <1.93 is not installed. Versions prior + # to 1.93 conflict with Links SQL's 'Payments' table. + my $plugin_cfg = GT::Config->load("$cfg->{admin_root_path}/Plugins/plugin.cfg"); + if (exists $plugin_cfg->{PPC} and (!$plugin_cfg->{PPC}->{version} or $plugin_cfg->{PPC}->{version} < 1.93)) { + $out->("Old PPC plugin detected - you must upgrade the PPC plugin to 1.93 or above before upgrading Links SQL."); + die "Old PPC plugin detected - you must upgrade the PPC plugin to 1.93 or above before upgrading Links SQL."; + } + + require GT::SQL; + $Links::DB = my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + $Links::STASH{clicktrack_cleanup} = 1; + $Links::STASH{expired_links} = 1; + + my $lang = GT::Config->load("$cfg->{admin_root_path}/templates/admin/language.txt"); + + for my $table (qw/Users Links Category/) { + $out->("Updating $table subclasses...\n"); + # Create a new GT::SQL::Table object manually as I do _not_ want to + # load the existing subclasses. + my $t = GT::SQL::Table->new( + name => "$DB->{connect}->{PREFIX}$table", + connect => $DB->{connect}, + debug => $DB->{_debug}, + _err_pkg => 'GT::SQL::Table' + ); + $t->subclass( + table => { $table => "Links::Table::$table" }, + html => { $table => "Links::HTML::$table" } + ); + $t->save_state(); + $out->("\tOkay!\n"); + } + + add_column($out, $DB, Category => Payment_Mode => { type => 'TINYINT', not_null => 1, default => 0, form_size => 1, form_names => [0,1,2,3], form_values => ['Use global settings','Not accepted','Optional','Required'], form_type => 'SELECT', form_display => $lang->{prompt_Payment_Mode} }); + add_column($out, $DB, Category => Payment_Description => { type => 'TEXT', form_display => $lang->{prompt_Payment_Description} }); + add_column($out, $DB, Links => ExpiryDate => { type => 'INT', not_null => 1, default => 0x7fff_ffff, form_display => $lang->{prompt_ExpiryDate}, form_size => 35 }); + add_column($out, $DB, Links => ExpiryCounted => { type => 'TINYINT', not_null => 1, default => 0, form_display => $lang->{prompt_ExpiryCounted}, form_type => 'hidden' }); + add_column($out, $DB, Links => ExpiryNotify => { type => 'TINYINT', not_null => 1, default => 0, form_display => $lang->{prompt_ExpiryNotify}, form_type => 'hidden' }); + drop_index($out, $DB, Links => 'valndx'); + add_index($out, $DB, Links => { + valexpndx => [qw/isValidated ExpiryDate/], + expiryndx => [qw/ExpiryDate ExpiryNotify/], + expcntndx => [qw/ExpiryCounted ExpiryDate/] + }); + + add_table($out, $DB, "CatPrice", + cols => [ + cp_id => { type => 'INT', not_null => 1, unsigned => 1 }, + cp_cat_id_fk => { type => 'INT', not_null => 1, unsigned => 1 }, + cp_term => { type => 'CHAR', not_null => 1, size => 10 }, # e.g. 8d, 1m, 2y, 3w, unlimited, etc. + cp_cost => { type => 'FLOAT', not_null => 1 }, + cp_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = signup, 1 = renewal, 2 = recurring + cp_description => { type => 'TEXT' } + ], + pk => 'cp_id', + ai => 'cp_id', + fk => { Category => { cp_cat_id_fk => 'ID' } } + ); + + add_table($out, $DB, "Payments", + cols => [ + payments_id => { type => 'CHAR', not_null => 1, size => 16 }, + payments_linkid => { type => 'INT', unsigned => 1, not_null => 1 }, + payments_status => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = pending, 1 = completed, 2 = declined, 3 = error + payments_method => { type => 'CHAR', not_null => 1, size => 25 }, + payments_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = initial payment, 1 = renewal payment, 2 = recurring payment + payments_amount => { type => 'FLOAT', not_null => 1 }, + payments_term => { type => 'CHAR', not_null => 1, size => 8 }, # e.g. 8d, 1m, 2y, 3w, etc. + payments_start => { type => 'INT', not_null => 1, unsigned => 1 }, + payments_last => { type => 'INT', not_null => 1, unsigned => 1 }, + ], + pk => 'payments_id', + fk => { Links => { payments_linkid => 'ID' } }, + index => { + p_sl => ['payments_status', 'payments_last'], + p_ll => ['payments_linkid', 'payments_last'], + p_al => ['payments_amount', 'payments_last'], + } + ); + + add_table($out, $DB, "PaymentLogs", + cols => [ + paylogs_id => { type => 'INT', not_null => 1, unsigned => 1 }, + paylogs_payments_id => { type => 'CHAR', not_null => 1, size => 16 }, + paylogs_type => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = info, 1 = accepted, 2 = declined, 3 = error + paylogs_time => { type => 'INT', not_null => 1, unsigned => 1 }, + paylogs_viewed => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 }, + paylogs_text => { type => 'TEXT' }, + ], + pk => 'paylogs_id', + ai => 'paylogs_id', + fk => { Payments => { paylogs_payments_id => 'payments_id' } }, + index => { + pl_yt => ['paylogs_type', 'paylogs_time'], + pl_t => ['paylogs_time'] + } + ); + + recreate_table($out => $DB => ClickTrack => sub { my $table = shift; ($table->pk and @{$table->pk} != 0) }, + cols => [ + LinkID => { type => 'INT', not_null => 1 }, + IP => { type => 'CHAR', size => 25, not_null => 1 }, + ClickType => { type => 'ENUM', values => ['Rate', 'Hits','Review'], not_null => 1 }, + ReviewID => { type => 'INT', not_null => 1, default => 0}, + Created => { type => 'TIMESTAMP' } + ], + unique => { + ct_licr => ['LinkID', 'IP', 'ClickType','ReviewID'] + }, + index => { + cndx => ['Created'] + } + ); + + if (-e(my $oldconfig = "$cfg->{admin_root_path}/Links/ConfigData.pm")) { + $out->("Removing old Links/ConfigData.pm file (has been replaced with Links/Config/Data.pm)...\n"); + require GT::File::Tools; + my $ret = GT::File::Tools::move($oldconfig, "$oldconfig.old"); + $out->($ret ? "\tOkay!\n" : "\tAn error occured: $!\n"); + } + + $out->(DONE '2.1.2' => '2.2.0'); +} + +sub upgrade__2_1_1__2_1_2 { +# --------------------------------------------------------------- +# Upgrade from 2.1.1 to 2.1.2 +# + my ($out, $cfg) = @_; + $out->(PERFORM '2.1.1' => '2.1.2'); + +# Add session table. + import lib $cfg->{admin_root_path}; + require GT::SQL; + my $DB = GT::SQL->new( $cfg->{admin_root_path} . '/defs' ); + add_table($out, $DB, 'Sessions', + cols => [ + session_id => { type => 'CHAR', size => 32, not_null => 1, binary => '1' }, + session_user_id => { type => 'CHAR', not_null => 1 }, + session_date => { type => 'INT', not_null => 1 }, + session_data => { type => 'TEXT' } + ], + pk => 'session_id', + fk => { Users => { session_user_id => 'Username' } } + ); + + $out->(DONE '2.1.1' => '2.1.2'); +} + +sub upgrade__2_0_5__2_1_0 { +# --------------------------------------------------------------- +# Upgrade from 2.0.5 to 2.1.0 +# + my ($out, $cfg) = @_; + $out->(PERFORM '2.0.5' => '2.1.0'); + +# Add the review table. + import lib $cfg->{admin_root_path}; + require GT::SQL; + require GT::Config; + my $lang = GT::Config->load( $cfg->{admin_root_path} . '/templates/admin/language.txt' ); + my $DB = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + + add_table($out, $DB, 'Reviews', + cols => [ + ReviewID => { type => 'INT', not_null => 1, unsigned => 1, form_display => $lang->{'prompt_ReviewID'} }, + Review_LinkID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$', form_display => $lang->{'prompt_Review_LinkID'} }, + Review_Owner => { type => 'CHAR', size => 50, not_null => 1, form_display => $lang->{'prompt_Review_Owner'} }, + Review_Rating => { type => 'SMALLINT', unsigned => 1, not_null => 1, default => 0, regex => '^\d+$', form_display => $lang->{'prompt_Review_Rating'} }, + Review_Date => { type => 'DATE', not_null => 1, form_display => $lang->{'prompt_Review_Date'} }, + Review_Subject => { type => 'CHAR', size => 100, not_null => 1, form_display => $lang->{'prompt_Review_Subject'} }, + Review_Contents => { type => 'TEXT', not_null => 1, form_display => $lang->{'prompt_Review_Contents'} }, + Review_ByLine => { type => 'CHAR', size => 50, form_display => $lang->{'prompt_Review_ByLine'} }, + Review_WasHelpful => { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => $lang->{'prompt_Review_WasHelpful'} }, + Review_WasNotHelpful=> { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => $lang->{'prompt_Review_WasNotHelpful'} }, + Review_Validated => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => $lang->{'prompt_Review_Validated'} }, + Review_GuestName => { type => 'CHAR', size => 75, form_display => $lang->{'prompt_Review_GuestName'} }, + Review_GuestEmail => { type => 'CHAR', size => 75, regex => '^(?:(?:.+\@.+\..+)|\s*)$', form_display => $lang->{'prompt_Review_GuestEmail'} }, + ], + pk => 'ReviewID', + ai => 'ReviewID', + index => { rownerndx => ['Review_Owner'], rdatendx => ['Review_Date'], rlinkndx => ['Review_LinkID'] }, + fk => { Links => { Review_LinkID => 'ID' }, Users => { Review_Owner => 'Username' }} + ); + + add_column($out, $DB, ClickTrack => ReviewID => { type => 'INT', not_null => 1, default => 0 }); + +# Set default review options. + my %default_review = ( + user_review_required => 1, + reviews_per_page => 5, + review_sort_by => 'Review_Date', + review_convert_br_tags => 1, + review_days_old => 7 + ); + while (my ($k, $v) = each %default_review) { + $cfg->{$k} = $v unless exists $cfg->{$k}; + } + + $out->(DONE '2.0.5' => '2.1.0'); +} + +sub upgrade__2_0_3__2_0_4 { +# --------------------------------------------------------------- +# Upgrade from 2.0.3 to 2.0.4. +# + my ($out, $cfg) = @_; + + $out->(PERFORM '2.0.3' => '2.0.4'); + + import lib $cfg->{admin_root_path}; + require GT::SQL; + my $db = GT::SQL->new($cfg->{admin_root_path} . '/defs'); + + add_column($out, $db, Links => Contact_Name => { type => 'CHAR', size => 255 }); + add_column($out, $db, Links => Contact_Email => { type => 'CHAR', size => 255 }); + add_column($out, $db, Category => Category_Template => { type => 'CHAR', size => 40 }); + add_column($out, $db, MailingIndex => messageformat => { type => 'ENUM', values => [qw[text html]], not_null => 1, default => 'text' }); + + $out->(DONE '2.0.3' => '2.0.4'); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Add.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Add.pm new file mode 100644 index 0000000..f8e2e66 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Add.pm @@ -0,0 +1,303 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Add.pm,v 1.59 2007/12/20 20:31:35 brewt 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 Links::User::Add; +# ================================================================== +use strict; +use Links qw/:objects :payment/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# ------------------------------------------------------------------- +# Display either an add form or process an add request. +# + if ($CFG->{user_required} and !$USER) { + print $IN->redirect(Links::redirect_login_url('add')); + return; + } + + my $custom; + if (exists $CFG->{payment}->{remote}->{used}->{PayPal} and $custom = $IN->param('custom') and substr($custom, 0, 3) eq 'do;') { + substr($custom, 0, 3) = ''; + my @pairs = split /;/, $custom; + for (@pairs) { + my ($key, $val) = split /=/, $_; + next unless $key and $val; + $IN->param($key => $val) unless $IN->param($key); + } + } + + print $IN->header; + +# We are processing an add request. + if ($IN->param('add')) { + my $results = $PLG->dispatch('user_add_link', \&add_link); + if (defined $results->{error}) { + print Links::SiteHTML::display('add', $results); + } + else { + $results = Links::SiteHTML::tags('link', $results); + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD_SUCCESS'), "$CFG->{db_cgi_url}/add.cgi"); + if ($CFG->{payment}->{enabled}) { + require Links::Payment; + my @cats = $IN->param('CatLinks.CategoryID'); + my $opt = Links::Payment::load_cat_price(\@cats); + if (exists $opt->{error}) { + print Links::SiteHTML::display('error', $opt); + } + elsif ($opt->{payment_mode} == NOT_ACCEPTED) { + if ($CFG->{admin_email_add}) { + Links::send_email('link_added.eml', $results, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + print Links::SiteHTML::display('add_success', $results); + } + else {# payment option for this category is required or optional + $results->{link_id} = $results->{ID}; # we need a different tag since both Category and Link have ID + $opt->{CategoryID} = delete $opt->{ID}; # remove category id + $opt->{CategoryDescription} = delete $opt->{Description}; + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$results->{link_id}"); + print Links::SiteHTML::display('payment', { %$results, %$opt }); + } + } + else { + if ($CFG->{admin_email_add}) { + Links::send_email('link_added.eml', $results, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + print Links::SiteHTML::display('add_success', $results); + } + } + } +# We are processing a payment request. + elsif ($IN->param('process_payment') and $CFG->{payment}->{enabled}) { + my $payment_term = $IN->param('payment_term') || ''; + my $do = $IN->param('do'); + if ($payment_term eq 'free') { + my $link = $DB->table('Links')->get($IN->param('link_id')); + if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) { + print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') }); + return; + }; + $link = Links::SiteHTML::tags('link', $link); + +# Set ExpiryDate to free + $link->{'CatLinks.CategoryID'} = $IN->param('cat_id'); + $link->{ExpiryDate} = FREE; + $link->{ExpiryNotify}= 0; +# Update the link + $DB->table('Links')->update({ ExpiryDate => FREE, ExpiryNotify => 0 }, { ID => $link->{ID} }); +# Update the Timestmp for link's categories so they get rebuilt with build changed + my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list; + $DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats }); + +# Add some special tags for formatting. + @cats = $DB->table('Category', 'CatLinks')->select('Category.Full_Name', { 'CatLinks.LinkID' => $link->{ID} })->fetchall_list; + $link->{Category} = join "\n", sort @cats; + $link->{Category_loop} = [sort @cats]; + $link->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none'; + $link->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none'; + $link->{AutoValidate} = $CFG->{build_auto_validate}; + if ($CFG->{admin_email_add}) { + Links::send_email('link_added.eml', $link, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + $link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD_SUCCESS'), "$CFG->{db_cgi_url}/add.cgi"); + print Links::SiteHTML::display('add_success', $link); + } + elsif ($IN->param('payment_success')) { + print Links::SiteHTML::display('payment_success', { main_title_loop => Links::Build::build('title', Links::language('LINKS_PAYMENT_SUCCESS'), $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : ''))) }); + } + elsif ($do =~ /^payment_(method|form|direct)$/) { + require Links::Payment; + my $vars = Links::Payment->$1(); + my $page = $IN->param('page') || $IN->param('do'); + my $opt = Links::Payment::load_cat_price($IN->param('cat_id')); + if ($opt->{payment_mode} == NOT_ACCEPTED) { + print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') }); + return; + } + my $link = $DB->table('Links')->get($IN->param('link_id')); + if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) { + print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') }); + return; + } + $link = Links::SiteHTML::tags('link', $link); + + $link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{ID}"); + print Links::SiteHTML::display($page, { %$vars, %$opt, %$link }); + } + else { + print Links::SiteHTML::display('error', { error => "Invalid action" }); + } + } +# We are displaying an add form. + else { + my @id = grep { /^\d+$/ } $IN->param('ID'); + +# If we don't have an id, and can't generate a list, let's send the user a message. + if (!@id and !$CFG->{db_gen_category_list}) { + print Links::SiteHTML::display('error', { error => Links::language('ADD_SELCAT') }); + } + else { +# Otherwise display the add form. + if ($USER) { + $IN->param('Contact_Name') or ($IN->param('Contact_Name', $USER->{Name} || $USER->{Username})); + $IN->param('Contact_Email') or ($IN->param('Contact_Email', $USER->{Email})); + } + + if ($DB->table('Category')->count == 0) { + print Links::SiteHTML::display('error', { error => Links::language('ADD_NOCATEGORIES') }); + } +# If we're not generating a category list, the add form can't be shown without a valid category ID. + elsif (!$CFG->{db_gen_category_list} and $DB->table('Category')->count({ ID => \@id }) == 0) { + print Links::SiteHTML::display('error', { error => Links::language('ADD_INVALIDCAT', join(', ', @id)) }); + } + else { + my $category = {}; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + $category = Links::Tools::category_list(); + $category->{Category} = sub { Links::Tools::category_list_html() }; + } + print Links::SiteHTML::display('add', { + main_title_loop => Links::Build::build('title', Links::language('LINKS_ADD'), "$CFG->{db_cgi_url}/add.cgi" . (@id ? "?ID=" . join(';ID=', @id) : '')), + %$category + }); + } + } + } +} + +sub add_link { +# -------------------------------------------------------- +# Add the link to the database. +# + my $class = shift; + my @id = $IN->param('CatLinks.CategoryID'); + my %ret; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + %ret = %{Links::Tools::category_list()}; + $ret{Category} = sub { Links::Tools::category_list_html() }; + } + $ret{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD'), "$CFG->{db_cgi_url}/add.cgi" . (@id ? "?ID=" . join(';ID=', @id) : '')); + +# Check the referer. + if (@{$CFG->{db_referers}}) { + my $found = 0; + if ($ENV{'HTTP_REFERER'}) { + foreach (@{$CFG->{db_referers}}) { $ENV{'HTTP_REFERER'} =~ /\Q$_\E/i and $found++ and last; } + } + unless ($found) { + return { error => Links::language('ADD_BADREFER', $ENV{'HTTP_REFERER'}), %ret }; + } + } + +# Get our form data. + my $input = $IN->get_hash; + +# Check if the link is valid + if ($CFG->{user_link_validation}) { + require Links::Tools; + my $status = Links::Tools::link_status($input->{URL}); + if ($status and $Links::Tools::STATUS_BAD{$status}) { + return { error => Links::language('ADD_BADSTATUS', $Links::Tools::STATUS_BAD{$status}), %ret }; + } + } + + my $db = $DB->table('Links'); + my $cdb = $DB->table('Category'); + +# Columns the user should not be passing in + for my $key (qw/ID LinkOwner Add_Date Mod_Date Timestmp Date_Checked ExpiryDate ExpiryCounted ExpiryNotify LinkExpired/) { + delete $input->{$key}; + } + + for my $key (keys %{$CFG->{add_system_fields}}) { + $input->{$key} = $CFG->{add_system_fields}->{$key}; + } + +# Set the LinkOwner + $input->{LinkOwner} = $USER ? $USER->{Username} : 'admin'; + +# Set date variable to today's date. + Links::init_date(); + my $today = GT::Date::date_get(); + $input->{Add_Date} = $today; + $input->{Mod_Date} = $today; + +# Backward compatibility + $input->{Contact_Name} = $input->{'Contact_Name'} || $input->{'Contact Name'} || ($USER ? $USER->{Name} : ''); + $input->{Contact_Email} = $input->{'Contact_Email'} || $input->{'Contact Email'} || ($USER ? $USER->{Email} : ''); + + $input->{isValidated} = ($CFG->{build_auto_validate} == 1 and $USER or $CFG->{build_auto_validate} == 2) ? 'Yes' : 'No'; + +# Check the category + my @cids = $IN->param('CatLinks.CategoryID'); + my @name; + if (@cids) { + foreach my $cid (@cids) { + next if (! $cid); + my $sth = $cdb->select('Full_Name', { ID => $cid }); + $sth->rows or return { error => Links::language('ADD_INVALIDCAT', $cid), %ret }; + push @name, $sth->fetchrow; + } + if (@name) { + $input->{'CatLinks.CategoryID'} = \@cids; + } + } + + my $take_payments = ( + $CFG->{payment}->{enabled} + and + ( + $cdb->count(GT::SQL::Condition->new(Payment_Mode => '>=' => OPTIONAL, ID => '=' => \@cids)) + or + ( + $CFG->{payment}->{mode} >= OPTIONAL and + $cdb->count(GT::SQL::Condition->new(Payment_Mode => '=' => GLOBAL, ID => '=' => \@cids)) + ) + ) + ); + +# Set the payment expiry +# Set this to unlimited when payment is turned off so that if payment is turned on +# at a later date, those users aren't forced to pay. + $input->{ExpiryDate} = $CFG->{payment}->{enabled} && $take_payments ? UNPAID : FREE; + +# Setup the language for GT::SQL. + local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL'); + local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE'); + local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL'); + local $Links::Table::Links::ERRORS->{NOCATEGORY} = Links::language('ADD_NOCATEGORY'); + $Links::Table::Links::ERRORS if 0; # silence -w + +# Add the record. + my $id = $db->add($input); + $input->{ID} = $id; + if (! $id) { + my $error = "
          " . join('', map "
        • $_
        • ", $db->error) . "
        "; + return { error => $error, %ret }; + } + +# Add some special tags for formatting. + $input->{Category} = join "\n", sort @name; + $input->{Category_loop} = [sort @name]; + $input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none'; + $input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none'; + $input->{AutoValidate} = $CFG->{build_auto_validate}; + +# Send the visitor to the success page. + return $input; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Editor.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Editor.pm new file mode 100644 index 0000000..b1ca007 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Editor.pm @@ -0,0 +1,126 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Editor.pm,v 1.15 2009/05/09 06:40:54 brewt 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 Links::User::Editor; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::Browser::Controller; +use Links::Browser; +use Links::SiteHTML; + +sub handle { +# ------------------------------------------------------------------ +# This script is only available to users who have logged on. +# + unless ($USER) { + my $url = $IN->url(absolute => 1, query_string => 1); + $url = $IN->escape($url); + $url = $CFG->{db_cgi_url} . "/user.cgi?url=$url;from=browser"; + print $IN->redirect($url); + return; + } + my $editors = $DB->table('Editors'); + my @nodes; + my $perms = {}; + +# Get a controller to manage access. + my $ctrl = Links::Browser::Controller->new(user => $USER); + + if ($USER->{Status} eq 'Administrator') { + $ctrl->{admin} = 1; + } + else { + my $sth = $editors->select({ Username => $USER->{Username} }); + if ($sth->rows) { + while (my $ed = $sth->fetchrow_hashref) { + push @nodes, $ed->{CategoryID}; + $perms->{$ed->{CategoryID}} = $ed; + } + } + unless (@nodes) { + print $IN->header; + print Links::SiteHTML::display('error', { error => Links::language('BROWSER_NOTEDITOR') }); + return; + } + } + +# Handle the special condition which related to viewing +# and downloading files. Must remap the passed column +# values so Jump functions properly. + my $method = $IN->param('do'); + if ($method and $method =~ m/^(?:(v)iew|(download))_file$/) { + $IN->param($+, $IN->param('cn')); + $IN->param('ID', $IN->param('link_id') || $IN->param('id')); + $IN->param('DB', $IN->param('db')); + require Links::User::Jump; + return Links::User::Jump::handle(); + } + elsif ($method and $method =~ m/^(?:(v)iew|(download))_tmp_file$/) { + my $download = $2; + # view_tmp_file doesn't go through Jump because only editors are + # allowed to see them - the tmp files are used for pending Changes. + my $col = $IN->param('cn'); + my $id = $IN->param('link_id'); + my $changes = $DB->table('Changes')->select({ LinkID => $id })->fetchrow_hashref; + + my ($linkinfo, $fh); + if ($changes) { + $linkinfo = eval $changes->{ChgRequest}; + if ($linkinfo and -f $linkinfo->{$col}) { + my $colfh = \do { local *FH; *FH }; + if (open $colfh, "<$linkinfo->{$col}") { + $fh = $colfh; + binmode $fh; + } + } + } + if (!$fh) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_UNKNOWN', $id) }); + return; + } + + (my $filename = $linkinfo->{"${col}_filename"} || $linkinfo->{$col}) =~ s{.*[/\\]}{}; + print $IN->header($IN->file_headers( + filename => $filename, + inline => $download ? 0 : 1, + size => -s $linkinfo->{$col} + )); + + while (read $fh, my $buffer, 64*1024) { + print $buffer; + } + + return 1; + } + +# Load the tree if it is under 200 categories. + $ctrl->{load_tree} = 1; + $ctrl->{user_base_node} = \@nodes; + $ctrl->{perms} = $perms; + $ctrl->{admin_templates} = 0; + +# Begin the script. + print $IN->header(-charset => $CFG->{header_charset}); + $method = $ctrl->can_run; + if ($method) { + my $browser = Links::Browser->new(ctrl => $ctrl); + $PLG->dispatch("browser_$method", sub { $browser->$method(); }, $browser); + } + else { + print Links::SiteHTML::display('error', { error => Links::language('BROWSER_UNAUTHORIZED') }); + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Jump.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Jump.pm new file mode 100644 index 0000000..698de88 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Jump.pm @@ -0,0 +1,186 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Jump.pm,v 1.26 2006/02/20 22:38:31 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 Links::User::Jump; +# ================================================================== +use strict; +use Links qw/:objects :payment/; +use Links::SiteHTML; + +sub handle { +# -------------------------------------------------------------- +# Jump to a given ID. +# + $PLG->dispatch('jump_link', \&_plg_jump, {}); +} + +sub _plg_jump { +# -------------------------------------------------------------- +# Jump to a given link. +# + my $links = $DB->table('Links'); + my $id = $IN->param('ID') || $IN->param('Detailed'); + my $action = $IN->param('action') || ''; + my $goto = ''; + my $rec = {}; + + if ($CFG->{framed_jump} and $id and $action eq 'jump_frame') { + my $error; + if ($id !~ /^\d+$/) { + $error = Links::language('JUMP_INVALIDID', $id); + } + else { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + unless ($rec) { + $error = Links::language('JUMP_INVALIDID', $id); + $rec = {}; + } + elsif ($CFG->{build_detailed}) { + $rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id); + } + } + print $IN->header(); + print Links::SiteHTML::display('jump_frame', { error => $error, %$rec }); + return; + } + +# If we are chosing a random link, then get the total and go to one at random. + if (lc $id eq "random") { + my $offset = int rand $links->count(VIEWABLE); + $links->select_options("LIMIT 1 OFFSET $offset"); + my $sth = $links->select(qw/ID URL/ => VIEWABLE); + ($id, $goto) = $sth->fetchrow_array; + } + elsif (defined $id) { + if ($id !~ /^\d+$/) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + +# Find out if we're going to be displaying a file + my $col = $IN->param('v') || $IN->param('dl') || $IN->param('view') || $IN->param('download'); + + if ($col) { +# in this case, we need to know from what table we want to load our data from. +# It will by default pull information from the Links table, however if the +# DB=tablename option is used, it will apply the request to that table instead + my $table_name = $IN->param('DB') || 'Links'; + + unless ($table_name =~ m/^\w+$/) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLEFORMAT' ) }); + return; + }; + + if ($table_name ne 'Links') { + eval { $links = $DB->table($table_name) }; + if ($@) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLE', $table_name, $GT::SQL::error) }); + return; + } + } + + my $fh; + eval { $fh = $links->file_info($col, $id); }; + if ($fh) { + if ($IN->param('v') or $IN->param('view')) { # Viewing + print $IN->header($IN->file_headers( + filename => $fh->File_Name, + mimetype => $fh->File_MimeType, + inline => 1, + size => $fh->File_Size + )); + } + else { # Downloading + print $IN->header($IN->file_headers( + filename => $fh->File_Name, + mimetype => $fh->File_MimeType, + inline => 0, + size => $fh->File_Size + )); + } + binmode $fh; + while (read($fh, my $buffer, 65536)) { + print $buffer; + } + return 1; + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_UNKNOWN', $id) }); + return; + } + } +# Jump to a URL, bump the hit counter. + else { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + unless ($rec) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + $goto = $rec->{URL}; + + my $clicktrack = $DB->table('ClickTrack'); + my $rows = $clicktrack->count({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits' }); + unless ($rows) { + eval { + $clicktrack->insert({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits', Created => \"NOW()" }); + $links->update({ Hits => \"Hits + 1" }, { ID => $id }, { GT_SQL_SKIP_INDEX => 1 }); + }; + } + } + } +# Oops, no link. + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + + unless (defined $goto) { + my $error = ($IN->param('ID') eq 'random') ? Links::language('RANDOM_NOLINKS') : Links::language('JUMP_INVALIDID', $id); + print $IN->header(); + print Links::SiteHTML::display('error', { error => $error }); + return; + } + +# Redirect to a detailed page if requested. + if ($CFG->{build_detailed} and $IN->param('Detailed')) { + $goto = Links::transform_url("$CFG->{build_detail_url}/" . $links->detailed_url($id)); + } + ($goto =~ m,^\w+://,) or ($goto = "http://$goto"); + if ($goto) { + if ($CFG->{framed_jump} and not ($CFG->{build_detailed} and $IN->param('Detailed'))) { + unless (keys %$rec) { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + } + $rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id) if $CFG->{build_detailed}; + print $IN->header(); + print Links::SiteHTML::display('jump', { destination => $goto, %$rec }); + return; + } + else { + print $IN->redirect($goto); + } + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Login.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Login.pm new file mode 100644 index 0000000..34c201d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Login.pm @@ -0,0 +1,263 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Login.pm,v 1.19 2005/05/08 09:56:44 brewt 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 Links::User::Login; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# ------------------------------------------------------------------- +# Determine what to do. +# + my $input = $IN->get_hash; + my $mtl = Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi"); + if ($input->{login}) { + $PLG->dispatch('user_login', \&login_user); + } + elsif ($input->{signup_user}) { + $PLG->dispatch('user_signup', \&signup_user); + } + elsif ($input->{validate_user}) { + $PLG->dispatch('user_validate', \&validate_user); + } + elsif ($input->{send_validate}) { + $PLG->dispatch('user_validate_email', \&send_validate); + } + elsif ($input->{send_pass} and $CFG->{user_allow_pass}) { + $PLG->dispatch('user_pass_email', \&send_pass); + } + elsif ($input->{signup_form}) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { Username => $IN->param('Username') || '', Password => '', Email => $IN->param('Email') || '', main_title_loop => Links::Build::build('title', Links::language('LINKS_SIGNUP'), "$CFG->{db_cgi_url}/user.cgi?signup_form=1") }); + } + elsif ($input->{validate}) { + print $IN->header(); + print Links::SiteHTML::display('validate_form', { main_title_loop => Links::Build::build('title', Links::language('LINKS_VALIDATE'), "$CFG->{db_cgi_url}/user.cgi?validate=1") }); + } + elsif ($input->{logout}) { + Links::Authenticate::auth('delete_session'); + $USER = undef; + print $IN->header(); + print Links::SiteHTML::display('login', { Username => '', Password => '', Email => '', error => Links::language('USER_LOGOUT'), main_title_loop => $mtl }); + } + elsif ($input->{email_pass} and $CFG->{user_allow_pass}) { + print $IN->header(); + print Links::SiteHTML::display('login_email', { main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") }); + } + else { + print $IN->header(); + print Links::SiteHTML::display('login', { Username => $IN->param('Username') || '', main_title_loop => $mtl }); + } +} +# ============================================================== + +sub login_user { +# -------------------------------------------------------- +# Logs a user in, and creates a session ID. +# + my $username = $IN->param('Username') || shift; + my $password = $IN->param('Password') || shift; + my $goto = shift || 'login_success'; + + my $mtl = Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi"); + +# Make sure we have both a username and password. + if (!$username or !$password) { + print $IN->header(); + print Links::SiteHTML::display('login', { error => Links::language('USER_BADLOGIN'), Username => $username, main_title_loop => $mtl }); + return; + } + +# Check that the user exists, and that the password is valid. + my $user = Links::init_user($username, $password); + if (!$user) { + print $IN->header(); + require Links::Authenticate; + if (Links::Authenticate::auth_valid_user({ Username => $username, Password => $password })) { + print Links::SiteHTML::display('login', { error => Links::language('USER_NOTVAL', $user->{Email}), Username => $user->{Username}, main_title_loop => $mtl }); + } + else { + print Links::SiteHTML::display('login', { error => Links::language('USER_BADLOGIN'), main_title_loop => $mtl }); + } + return; + } + +# Store the session in either a cookie or url based. + my $results = Links::Authenticate::auth('create_session', { Username => $user->{Username} }); + return if $results->{redirect}; + +# Get the $USER information. + $USER = Links::Authenticate::auth('get_user', { Username => $username, Password => $password, auto_create => 1 }); + + print $IN->header(); # In case the session didn't print it. + print Links::SiteHTML::display($goto, { %$user, main_title_loop => $mtl }); +} + +sub signup_user { +# -------------------------------------------------------- +# Signs a new user up. +# + my $username = $IN->param('Username'); + my $password = $IN->param('Password'); + my $email = $IN->param('Email'); + + my $mtl = Links::Build::build('title', Links::language('LINKS_SIGNUP'), "$CFG->{db_cgi_url}/user.cgi?signup_form=1"); + + if (!$username or !$password or !$email) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { error => Links::language('USER_INVALIDSIGNUP'), main_title_loop => $mtl }); + return; + } + unless ($email =~ /.\@.+\../) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { error => Links::language('USER_INVALIDEMAIL', $email), main_title_loop => $mtl }); + return; + } + +# Check that the username doesn't already exist. + my $db = $DB->table('Users'); + my $user = $db->get($username); + if ($user) { + print $IN->header(); + print Links::SiteHTML::display( 'signup_form', { error => Links::language('USER_NAMETAKEN', $username), main_title_loop => $mtl }); + return; + } + +# Check that the email address doesn't already exist. + my $hits = $db->count({ Email => $email }); + if ($hits) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { error => Links::language('USER_EMAILTAKEN', $email), main_title_loop => $mtl }); + return; + } + my ($code, $msg); + +# Add the user in, set defaults for fields not specified. + $user = $IN->get_hash(); + my $def = $db->default || {}; + foreach (keys %$def) { + $user->{$_} = $def->{$_} unless (exists $user->{$_}); + } + +# Send validation email if needed. + if ($CFG->{user_validation}) { + my $code = time . $$ . int rand 1000; + $user->{Status} = "Not Validated"; + $user->{Validation} = $code; + my $ret = $db->add($user); + if (!$ret) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { error => $db->error, main_title_loop => $mtl }); + return; + } + } + else { + $user->{Status} = "Registered"; + $user->{Validation} = 0; + my $ret = $db->add($user); + if (!$ret) { + print $IN->header(); + print Links::SiteHTML::display('signup_form', { error => $db->error, main_title_loop => $mtl }); + return; + } + } +# Print the welcome screen. + if ($CFG->{user_validation}) { + print $IN->header(); + print Links::SiteHTML::display('signup_success', { %$user, main_title_loop => $mtl }); + Links::send_email('validate.eml', $user) or die "Unable to send message: $GT::Mail::error"; + } + else { + my $results = Links::Authenticate::auth('create_session', { Username => $user->{Username} }); + $USER = Links::Authenticate::auth('get_user', { Username => $user->{Username}, Password => $user->{Password}, auto_create => 1 }); + print $IN->header(); + print Links::SiteHTML::display('signup_success', { %$user, main_title_loop => $mtl }); + } +} + +sub validate_user { +# -------------------------------------------------------- +# Validates a user. +# + my $code = $IN->param('code'); + $code =~ s/^\s*|\s*$//g; + + my $mtl = Links::Build::build('title', Links::language('LINKS_VALIDATE'), "$CFG->{db_cgi_url}/user.cgi?validate=1"); + + if (!$code) { + print $IN->header; + print Links::SiteHTML::display('validate_form', { error => Links::language('USER_INVALIDVAL'), main_title_loop => $mtl }); + return; + } + my $db = $DB->table('Users'); + my $sth = $db->select({ Validation => $code }); + my $user = $sth->fetchrow_hashref; + + if (! $user) { + print $IN->header; + print Links::SiteHTML::display('validate_form', { error => Links::language('USER_INVALIDVAL'), main_title_loop => $mtl }); + return; + } + $db->update({ Status => 'Registered' }, { Username => $user->{Username} }); + login_user($user->{Username}, $user->{Password}, 'validate_success'); +} + +sub send_pass { +# ------------------------------------------------------------------- +# Sends the user a password reminder email. +# + my $email = $IN->param('Email'); + my $user_db = $DB->table('Users'); + my $sth = $user_db->select( { Email => $email } ); + print $IN->header(); + my $user = $sth->fetchrow_hashref; + if ($user and $email =~ /.+\@.+\..+/) { + Links::send_email('password.eml', { %$user, %ENV }) or die "Unable to send message: $GT::Mail::error"; + print Links::SiteHTML::display('login', { error => Links::language('USER_PASSSENT'), Username => '', Password => '', main_title_loop => Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi") }); + } + else { + print Links::SiteHTML::display('login_email', { error => Links::language('USER_NOEMAIL'), main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") }); + } +} + +sub send_validate { +# ------------------------------------------------------------------- +# Sends the validation email if the user needs another one. +# + my $email = $IN->param('Email'); + my $user_db = $DB->table('Users'); + my $sth = $user_db->select( { Email => $email } ); + print $IN->header(); + if ($sth->rows) { +# Prepare the message. + my $user = $sth->fetchrow_hashref; + +# Make sure there is a validation code. + if (! $user->{Validation}) { + $user->{Validation} = (time) . ($$) . (int rand(1000)); + $user_db->modify($user); + } + Links::send_email('validate.eml', $user) or die "Unable to send message: $GT::Mail::error"; + + print Links::SiteHTML::display('login', { error => Links::language('USER_VALSENT'), Username => '', Password => '', main_title_loop => Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi") }); + } + else { + print Links::SiteHTML::display('login_email', { error => Links::language('USER_NOEMAIL'), main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") }); + } +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm new file mode 100644 index 0000000..13a0a4d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm @@ -0,0 +1,571 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Modify.pm,v 1.82 2013/02/01 04:43:56 brewt 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 Links::User::Modify; +# ================================================================== +use strict; +use Links qw/:objects :payment/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# --------------------------------------------------- +# Determine what to do. +# + my $link_id = $IN->param('LinkID'); + if ($CFG->{user_required} and !$USER) { + print $IN->redirect(Links::redirect_login_url('modify')); + return; + } + +# Perform the link modification + if ($IN->param('modify')) { + _modify(); + } + elsif ($USER) { +# Display the link modify form (for a specific link) + if ($IN->param('LinkID')) { + _modify_passed_in(); + } + else { + _list_owned_links(); + } + } +# Display the link modify form (used when user_required is off) + else { + _modify_form(); + } +} + +# ============================================================== + +sub _modify { +# -------------------------------------------------------- +# Modifies a link. +# +# If payment is enabled and we are processing a payment + if ($CFG->{payment}->{enabled} and $IN->param('process_payment')) { + my $payment_term = $IN->param('payment_term') || ''; + my $do = $IN->param('do') || ''; + if ($payment_term eq 'free') { + print $IN->header(); + my $link = $DB->table('Links')->get(scalar $IN->param('link_id')); + my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY_SUCCESS'), "$CFG->{db_cgi_url}/modify.cgi"); + if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) { + print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER'), main_title_loop => $mtl }); + return; + } + $link = Links::SiteHTML::tags('link', $link); + +# Add some special tags for formatting. + $link->{Category} = $DB->table('Category', 'CatLinks')->select('Category.Full_Name', { 'CatLinks.LinkID' => $link->{ID} })->fetchrow; + +# Set ExpiryDate to free + $link->{'CatLinks.CategoryID'} = $IN->param('cat_id'); + $link->{ExpiryDate} = FREE; + $link->{ExpiryNotify}= 0; +# Update the link + $DB->table('Links')->update({ ExpiryDate => FREE, ExpiryNotify => 0 }, { ID => $link->{ID} }); +# Update the Timestmp for link's categories so they get rebuilt with build changed + my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list; + $DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats }); + + print Links::SiteHTML::display('modify_success', { %$link, main_title_loop => $mtl }); + } + elsif ($do eq 'payment_linked') { + print $IN->header; + my $link = $DB->table('Links', 'CatLinks')->select({ ID => scalar $IN->param('ID') })->fetchrow_hashref; + if (!$link) { + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOLINKS') }); + return; + } + elsif ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username}) { + print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTOWNER') }); + return; + } + $link = Links::SiteHTML::tags('link', $link); + + require Links::Payment; + my @cid = $DB->table('CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list; + my $opt = Links::Payment::load_cat_price(\@cid); + if ($opt->{payment_mode} == NOT_ACCEPTED) { + print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') }); + return; + } + $link->{link_id} = $link->{ID}; # we need a different tag since both Category and Link have ID + $opt->{CategoryID} = delete $opt->{ID}; # remove category id + $opt->{CategoryDescription} = delete $opt->{Description}; + $link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{link_id}"); + print Links::SiteHTML::display('payment', { %$link, %$opt }); + } + elsif ($do =~ /^payment_(method|form|direct)$/) { + require Links::Payment; + my $vars = Links::Payment->$1(); + my $page = $IN->param('page') || $IN->param('do'); + my $opt = Links::Payment::load_cat_price($IN->param('cat_id')); + if ($opt->{payment_mode} == NOT_ACCEPTED) { + print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') }); + return; + } + my $link = $DB->table('Links')->get($IN->param('link_id')); + print $IN->header(); + if (not $link or $link->{LinkOwner} ne $USER->{Username}) { + print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') }); + return; + } + $link = Links::SiteHTML::tags('link', $link); + + $link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{ID}"); + print Links::SiteHTML::display($page, { %$vars, %$opt, %$link }); + } + else { + print $IN->header; + print Links::SiteHTML::display('error', { error => "Invalid action" }); + } + } +# Otherwise, modify the link + else { + my $results = $PLG->dispatch('user_modify_link', \&modify_link, {}); + if (defined $results->{error}) { + print $IN->header(); + print Links::SiteHTML::display('modify', $results); + } + else { + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_MODIFY_SUCCESS'), "$CFG->{db_cgi_url}/modify.cgi"); + if ($CFG->{payment}->{enabled}) { + require Links::Payment; + my @cid = $IN->param('CatLinks.CategoryID'); + my $opt = Links::Payment::load_cat_price(\@cid); + print $IN->header(); + if (exists $opt->{error}) { + print Links::SiteHTML::display('error', $opt); + } + elsif ($opt->{payment_mode} == NOT_ACCEPTED or ($results->{ExpiryDate} >= time)) { + print Links::SiteHTML::display('modify_success', $results); + } + else {# display payment form if the link is expired or payment mode for this category is required or optional + $results->{link_id} = $results->{ID}; # we need a different tag since both Category and Link have ID + $opt->{CategoryID} = delete $opt->{ID}; # remove category id + $opt->{CategoryDescription} = delete $opt->{Description}; + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$results->{link_id}"); + print Links::SiteHTML::display('payment', {%$results,%$opt}); + } + } + else { + print $IN->header(); + print Links::SiteHTML::display('modify_success', $results); + } + } + } +} + +sub _modify_passed_in { +# -------------------------------------------------------- +# Display link that was passed in. +# + my $lid = $IN->param('LinkID'); + my $link_db = $DB->table('Links'); + my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi?LinkID=$lid"); + my $sth = $link_db->select({ ID => $lid, LinkOwner => $USER->{Username} }, VIEWABLE); + if ($sth->rows) { + my $link = $sth->fetchrow_hashref; + my @ids = $DB->table('CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list; + $IN->param('CatLinks.CategoryID', \@ids); + + $link->{Contact_Name} ||= $USER->{Name} || $USER->{Username}; + $link->{Contact_Email} ||= $USER->{Email}; + + my $category = {}; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + $category = Links::Tools::category_list(); + $category->{Category} = sub { Links::Tools::category_list_html() }; + } + print $IN->header(); + print Links::SiteHTML::display('modify', { + main_title_loop => $mtl, + %$link, + %$category + }); + } + elsif (!$CFG->{user_required}) { + _modify_form(); + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOTOWNER'), LinkID => $lid, main_title_loop => $mtl }); + } +} + +sub _list_owned_links { +# -------------------------------------------------------- +# Display a list of links the user owns. +# + my $link_db = $DB->table('Links'); + my ($limit, $offset, $nh) = Links::limit_offset(); + my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi"); + $link_db->select_options("ORDER BY Title ASC", "LIMIT $limit OFFSET $offset"); + my $sth = $link_db->select({ + LinkOwner => $USER->{Username}, + # If payment is enabled, we want to show non-validated links to allow + # payment to occur, otherwise only show validated ones + ($CFG->{payment}->{enabled} ? () : (isValidated => 'Yes')) + }); + my $total = $link_db->hits; + if (! $sth->rows) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOLINKS'), main_title_loop => $mtl }); + return; + } + my ($toolbar, %paging); + my @links; + while (my $hash = $sth->fetchrow_hashref) { + push @links, Links::SiteHTML::tags('link', $hash); + } + if ($total > $limit) { + my $url = $CFG->{db_cgi_url} . "/" . $IN->url; + $toolbar = $DB->html(['Links'], $IN)->toolbar($nh, $limit, $total, $url); + %paging = ( + url => $url, + num_hits => $total, + max_hits => $limit, + current_page => $nh + ); + } + print $IN->header(); + print Links::SiteHTML::display('modify_select', { + link_results_loop => \@links, + main_title_loop => $mtl, + total => $total, + next => $toolbar, + paging => \%paging + }); +} + +sub _modify_form { +# -------------------------------------------------------- +# Just display the regular form. +# + my @id = $IN->param('ID'); # Category ID. + my $link = {}; + print $IN->header(); + if ($IN->param('LinkID')) { + my $lid = $IN->param('LinkID'); + $link = $DB->table('Links')->select({ ID => $lid }, VIEWABLE)->fetchrow_hashref; + if (!$link) { + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_INVALIDLINKID', $lid) }); + return; + } + if (!@id) { + @id = $DB->table('CatLinks')->select('CategoryID', { LinkID => $lid })->fetchall_list; +# Set ID to the categories that the link is in so Links::Tools::category_list +# pre-selects them + $IN->param(ID => \@id); + } + } + + if (!@id and !$CFG->{db_gen_category_list}) { + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_SELCAT') }); + } + else { + my $category = {}; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + $category = Links::Tools::category_list(); + $category->{Category} = sub { Links::Tools::category_list_html() }; + } + print Links::SiteHTML::display('modify', { + main_title_loop => Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi" . (@id ? "?ID=" . join(';ID=', @id) : '')), + %$category, + %$link + }); + } +} + +sub modify_link { +# -------------------------------------------------------- +# Change the requested link. +# + my $args = $IN->get_hash(); + my $db = $DB->table('Links'); + my %cols = $db->cols; + +# Make it possible to use any column to find the link we're modifying. +# Normally, we use the LinkID to find the link, but in some conditions the URL +# is used. Using this isn't recommended as you're not guaranteed to get the +# same or unique results. + my ($column, $value); + foreach my $col (keys %cols) { + if (exists $args->{'Current_' . $col} and $args->{'Current_' . $col}) { + $column = $col; + $value = $args->{'Current_' . $col}; + last; + } + } + + my $lid = $args->{LinkID}; + my %ret; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + %ret = %{Links::Tools::category_list()}; + $ret{Category} = sub { Links::Tools::category_list_html() }; + } + $ret{main_title_loop} = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi" . ($lid ? "?LinkID=$lid" : '')); + $ret{LinkID} = $lid; + unless ($value or ($lid and $USER)) { + return { error => Links::language('MODIFY_NOURL'), %ret }; + } + +# Find the requested link + my ($link, $sth); + if ($USER and $lid) { + #if ($CFG->{user_required}) { +# Mod added back on April 10 by Virginia + if ($CFG->{user_required} and $USER->{Status} ne 'Administrator') { # mod by Virginia Lo on Oct 29, 2007 + $sth = $db->select({ ID => $lid, LinkOwner => $USER->{Username} }); + } + else { + $sth = $db->select({ ID => $lid }); + } + $sth->rows or return { error => Links::language('MODIFY_INVALIDLINKID', $lid), %ret }; + } + else { + $sth = $db->select({ $column => $value }); + $sth->rows or return { error => Links::language('MODIFY_BADURL', $value), %ret }; + } + $link = $sth->fetchrow_hashref; + +# Make sure to only allow modifications to validated links. We currently allow +# the user to modify expired links. + unless ($link->{isValidated} eq 'Yes') { + return { error => Links::language('MODIFY_NOLINKS'), %ret }; + } + + my $new = {%$args}; + +# Forced system fields (these aren't in the add_system_fields option) + my @system = qw/ID LinkOwner Add_Date Mod_Date Timestmp Date_Checked ExpiryDate ExpiryCounted ExpiryNotify LinkExpired/; + my %system = map { $_ => 1 } @system; + + for my $key (keys %cols) { +# Users can't modify system fields, so remove them so the columns don't get +# modified + if (exists $system{$key} or exists $CFG->{add_system_fields}->{$key}) { + delete $new->{$key}; + next; + } + +# Use the original link value if it hasn't been passed in from cgi. This is +# done to make sure all Links columns pass the column checks (not null, regex, +# etc checks). It has to be done for all columns, since column definitions may +# have changed since the record was originally inserted. + $new->{$key} = $link->{$key} unless defined $args->{$key}; + } + +# Check that the ExpiryDate is valid for the categories the link is in + if ($CFG->{payment}->{enabled}) { + require Links::Payment; + my $expiry = Links::Payment::check_expiry_date($link); + $new->{ExpiryDate} = $expiry if $expiry; + } + +# modify() needs the primary key to perform the update + $new->{ID} = $link->{ID}; + + Links::init_date(); + $new->{Mod_Date} = GT::Date::date_get(); + +# Backwards compatibility + $new->{Contact_Name} = $args->{Contact_Name} || $args->{'Contact Name'} || ($USER ? $USER->{Name} : ''); + $new->{Contact_Email} = $args->{Contact_Email} || $args->{'Contact Email'} || ($USER ? $USER->{Email} : ''); + +# Setup the language for GT::SQL + local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL'); + local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE'); + local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL'); + local $Links::Table::Links::ERRORS->{NOCATEGORY} = Links::language('MODIFY_NOCATEGORY'); + $Links::Table::Links::ERRORS if 0; # silence -w + +# On error, file column values need to be restored (since they need to get +# re-uploaded). This is done so that the templates show the correct fields on +# an error. + my %fcols = $db->_file_cols(); + for (keys %fcols) { + $ret{$_} = $link->{$_}; + } + +# Because we store the change request in the Changes table and do not perform +# the modify directly, all the column checks that modify() would normally do +# need to be done now. + my $fset; + unless ($USER and $CFG->{user_direct_mod}) { + if (keys %fcols) { + require GT::SQL::File; + my $file = GT::SQL::File->new({ parent_table => $DB->table('Links'), connect => $DB->{connect} }); + $fset = $file->pre_file_actions(\%fcols, $new, $args, $new->{ID}) or return { error => $GT::SQL::error, %ret }; + } + +# The following block of code modifies $new (so that _check_update() works +# properly), but we don't want that later on, so make a shallow copy of it. + my $new_copy = { %$new }; + +# This block of code is pulled from GT::SQL::Table::modify (minus the comments) + my $cols = $db->{schema}->{cols}; + for my $col (keys %$cols) { + next unless exists $new_copy->{$col}; + + if ($cols->{$col}->{type} eq 'TIMESTAMP') { + delete $new_copy->{$col}; + } + elsif ($cols->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL|DATE|TIME|DATETIME)$/ and defined $new_copy->{$col} and $new_copy->{$col} eq '') { + $new_copy->{$col} = undef; + } + elsif ($cols->{$col}->{not_null} and not (defined $new_copy->{$col} and length $new_copy->{$col})) { + $new_copy->{$col} = undef; + } + } + + $db->_check_update($new_copy, { ID => $new_copy->{ID} }) or return { error => $GT::SQL::error, %ret }; + } + +# Make sure the category id's are valid + $IN->param('CatLinks.CategoryID') + or return { error => Links::language('MODIFY_NOCATEGORY'), %ret }; + +# Set the Category ID's + my @c_ids = $IN->param('CatLinks.CategoryID'); + $new->{'CatLinks.CategoryID'} = $db->clean_category_ids(\@c_ids) + or return { error => $GT::SQL::error, %ret }; + +# Check if the link is valid + if ($CFG->{user_link_validation}) { + require Links::Tools; + my $status = Links::Tools::link_status($new->{URL}); + if ($status and $Links::Tools::STATUS_BAD{$status}) { + return { error => Links::language('MODIFY_BADSTATUS', $Links::Tools::STATUS_BAD{$status}), %ret }; + } + } + + my $orig_cats = $db->get_categories($new->{ID}); + my $new_cats; + +# Add the link either directly in, or into the change request table. + if ($USER and $CFG->{user_direct_mod}) { + if ($USER->{Status} ne 'Administrator' and $link->{LinkOwner} ne $USER->{Username}) { + return { error => Links::language('MODIFY_NOTOWNER'), %ret }; + } + + my $res = $db->modify($new) or return { error => $GT::SQL::error, %ret }; + $new_cats = $db->get_categories($new->{ID}); + } + else { + require GT::Dumper; + my $chg_db = $DB->table('Changes'); + +# Remove any columns which haven't changed + for my $key (keys %cols) { + next if not exists $new->{$key} or $key eq 'ID'; + + delete $new->{$key} if $new->{$key} eq (defined $link->{$key} ? $link->{$key} : ''); + } + +# Handle updating the expiry date later on (when the admin does the change +# validation). It can't be done here because payments can be made to the link +# before the change validation occurs, losing the user's updated expiry date. + delete $new->{ExpiryDate}; + +# pre_file_actions() pulls the file columns out of the $new hash; put them back +# in and save the uploaded file(s) in a temporary location for processing upon +# change validation. + foreach my $col (keys %fcols) { + if (exists $fset->{$col}) { + my $fh = $fset->{$col}; + my $fname = GT::CGI->escape(get_filename($fh)); + my $fpath = "$CFG->{admin_root_path}/tmp/$new->{ID}-$fname"; + + open F, ">$fpath"; + binmode F; binmode $fh; + my $buf; + while (read $fh, $buf, 4096) { print F $buf; }; + close F; + + $new->{$col} = $fpath; + $new->{"${col}_filename"} = $fset->{"${col}_filename"} || get_filename($fh); + } + elsif (exists $fset->{"${col}_del"}) { + $new->{"${col}_del"} = $fset->{"${col}_del"}; + } + } + + my $count = $chg_db->count({ LinkID => $new->{ID} }); + if ($count) { + my $href = $chg_db->select('ChgRequest', { LinkID => $new->{ID} })->fetchrow; + $href = eval $href; + foreach (keys %fcols) { + my $fpath = $href->{$_} or next; + $fpath ne $new->{$_} or next; + $fpath !~ /\.\./ or next; + $fpath =~ /^[\w\\\/\-\.%]+$/ or next; + -e $fpath or next; + $fpath =~ m,^\Q$CFG->{admin_root_path}\E/tmp/, or next; + unlink $fpath; + } + $chg_db->update({ LinkID => $new->{ID}, Username => $link->{LinkOwner}, ChgRequest => GT::Dumper->dump({ data => $new, var => '' }) }, { LinkID => $new->{ID} }) + or return { error => $GT::SQL::error, %ret }; + } + else { + $chg_db->insert({ LinkID => $new->{ID}, Username => $link->{LinkOwner}, ChgRequest => GT::Dumper->dump({ data => $new, var => '' }) }) + or return { error => $GT::SQL::error, %ret }; + } + my $cdb = $DB->table('Category'); + foreach my $id (@c_ids) { + my $cat = $cdb->get($id, 'HASH', ['Full_Name']); + $new_cats->{$id} = $cat->{Full_Name}; + } + } + +# Now email the site admin. + if ($CFG->{admin_email_mod}) { + my %tags; + for my $key (keys %$link) { + $tags{"Original_" . $key} = $link->{$key}; + $tags{"New_" . $key} = exists $new->{$key} ? $new->{$key} : $link->{$key}; + } +# Pull in the extra fields that might be in $new (eg. extra file data) + for my $key (keys %$new) { + next if exists $tags{"New_" . $key}; + $tags{"New_" . $key} = $new->{$key}; + } + $tags{Original_Category} = join "\n", sort values %$orig_cats; + $tags{Original_Category_loop} = [sort values %$orig_cats]; + $tags{New_Category} = join "\n", sort values %$new_cats; + $tags{New_Category_loop} = [sort values %$new_cats]; + + $GT::Mail::error ||= ''; + Links::send_email('link_modified.eml', \%tags, { admin_email => 1 }) or die "Unable to send message: $GT::Mail::error"; + } + $new->{Category} = join("\n", sort values %$new_cats); + $new->{Category_loop} = [sort values %$new_cats]; + +# All done! + return { %$args, %$link, %$new }; +} + +sub get_filename { +# ------------------------------------------------------------------- + my $fpath = shift; + my @path = split /[\\\/]/, $fpath; + return pop @path; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Page.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Page.pm new file mode 100644 index 0000000..a87090d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Page.pm @@ -0,0 +1,250 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Page.pm,v 1.33 2007/12/19 06:59:12 brewt 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 Links::User::Page; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# -------------------------------------------------------------- +# Wrap in a subroutine to prevent possible mod_perl probs. +# + $ENV{PATH_INFO} and ($ENV{PATH_INFO} =~ s/.*page\.cgi//); + my $page = $IN->param('g') || $ENV{PATH_INFO} || ''; + +# We can display a custom template by passing in p=template (the p is for +# page). + my $custom = $IN->param('p') || ''; + return generate_custom_page($custom) if $custom; + +# Clean up page a little. + $page =~ s|^/+||; + $page =~ s|/+$||; + +# Reset the grand total. + $Links::Build::GRAND_TOTAL = 0; + +# Figure out what to look for. + my ($new_match) = $CFG->{build_new_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)}; + my ($cool_match) = $CFG->{build_cool_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)}; + my ($rate_match) = $CFG->{build_ratings_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)}; + +# Strip out the index.html/more*.html if it is there. + $page =~ s{/*(?:\Q$CFG->{build_home}\E|\Q$CFG->{build_index}\E|\Q$CFG->{build_more}\E\d+\Q$CFG->{build_extension}\E)$}{}; + + if ($new_match and $page =~ m{^\Q$new_match\E(?:/|$)}) { + $PLG->dispatch('generate_new', \&generate_new_page); + } + elsif ($cool_match and $page =~ m{^\Q$cool_match\E(?:/|$)}) { + $PLG->dispatch('generate_cool', \&generate_cool_page); + } + elsif ($rate_match and $page =~ m{^\Q$rate_match\E/?$}) { + $PLG->dispatch('generate_rate', \&generate_rate_page); + } +# By default the detailed page format in dynamic mode will be +# "<%config.build_detailed_url%>/<%ID%>.<%build_extension%>", but other certain +# formats can be used without breaking other URLs. + elsif ($page =~ /\d+\Q$CFG->{build_extension}\E$/) { + $PLG->dispatch('generate_detailed', \&generate_detailed_page); + } + elsif ($page !~ /\S/) { + $PLG->dispatch('generate_home', \&generate_home_page); + } + elsif ($page =~ /(\w+\.cgi)/) { + print $IN->redirect("$CFG->{db_cgi_url}/$1"); + } + else { + $PLG->dispatch('generate_category', \&generate_category_page); + } +} + +sub generate_custom_page { +# -------------------------------------------------------- +# Displays a custom template. +# + my $page = shift; + if ($CFG->{dynamic_404_status}) { + my $template_set = Links::template_set(); + if (! Links::template_exists($template_set, "$page.html")) { + print "Status: 404" . $GT::CGI::EOL; + } + } + print $IN->header(); + print Links::SiteHTML::display($page, {}); +} + +sub generate_home_page { +# -------------------------------------------------------- +# Display the home page. +# + print $IN->header(); + print Links::Build::build(home => {}); +} + +sub generate_category_page { +# -------------------------------------------------------- +# This routine will display a category, first thing we need +# to do is figure out what category we've been asked for. +# + my $page_num = 1; + my $page = $IN->param('g') || $ENV{PATH_INFO} || ''; + $page_num = $1 if $page =~ s{/\Q$CFG->{build_more}\E(\d+)\Q$CFG->{build_extension}\E$}{}; + $page =~ s/\Q$CFG->{build_index}\E$//; + $page =~ s|^/+||; + $page =~ s|/+$||; + my $like = $page; + $page =~ y/_/ /; + +# Now we get the ID number of the category based on the URL. + my $cat_db = $DB->table('Category'); + my $id; + if ($CFG->{build_category_dynamic} eq 'ID' or $page =~ /^\d+$/) { + ($id) = $page =~ /(\d+)$/; +# Make sure the ID is valid + $id = $cat_db->select(ID => { ID => $id })->fetchrow; + } + else { + $id = $cat_db->select(ID => { ($CFG->{build_category_dynamic} || 'Full_Name') => $page })->fetchrow; + } + + if (!$id) { +# Oops, we may have had a escaped character '_' that wasn't a space. We need +# to look it up manually. + $like =~ y/'"//d; + $id = $cat_db->select(ID => GT::SQL::Condition->new(($CFG->{build_category_dynamic} || 'Full_Name') => LIKE => $like))->fetchrow; + } + +# Check for valid sort order. + my %opts; + $opts{id} = $id; + $opts{nh} = $page_num; + $opts{sb} = $IN->param('sb'); + $opts{so} = $IN->param('so'); + $opts{cat_sb} = $IN->param('cat_sb'); + $opts{cat_so} = $IN->param('cat_so'); + unless ($opts{sb} and exists $DB->table('Links')->cols->{$opts{sb}} and (not $opts{so} or $opts{so} =~ /^(?:desc|asc)$/i)) { + delete $opts{sb}; + delete $opts{so}; + } + unless ($opts{cat_sb} and exists $DB->table('Category')->cols->{$opts{cat_sb}} and (not $opts{cat_so} or $opts{cat_so} =~ /^(?:desc|asc)$/i)) { + delete $opts{cat_sb}; + delete $opts{cat_so}; + } + + if ($id) { + print $IN->header(); + print Links::Build::build('category', \%opts); + } + else { + print "Status: 404" . $GT::CGI::EOL if $CFG->{dynamic_404_status}; + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('PAGE_INVALIDCAT', $page) }); + } +} + +sub generate_new_page { +# -------------------------------------------------------- +# Creates a "What's New" page. Set build_span_pages to 1 in setup +# and it will create a seperate page for each date. +# + my ($page, $date); + + $page = $IN->param('g') || $ENV{PATH_INFO} || ''; + if ($page =~ /\Q$CFG->{build_index}\E$/) { + $date = ''; + } + else { + ($date) = $page =~ m{/([^/]+)\Q$CFG->{build_extension}\E$}; + } + + if ($date) { + my $nh = 1; + my $lpp = $CFG->{build_links_per_page} || 25; + if ($date =~ s/_(\d+)//) { + $nh = $1; + } + print $IN->header(); + print Links::Build::build('new_subpage', { date => $date, mh => $lpp, nh => $nh }); + } + elsif ($CFG->{build_new_date_span_pages}) { + print $IN->header(); + print Links::Build::build('new_index', {}); + } + else { + print $IN->header(); + print Links::Build::build('new', {}); + } +} + +sub generate_cool_page { +# -------------------------------------------------------- +# Creates a "What's Cool" page. +# + my $page = $IN->param('g') || $ENV{PATH_INFO} || ''; + my $nh = 1; + my $mh = $CFG->{build_span_pages} ? $CFG->{build_links_per_page} : 1000; + if ($page =~ /\Q$CFG->{build_more}\E(\d+)\Q$CFG->{build_extension}\E$/) { + $nh = $1; + } + print $IN->header(); + print Links::Build::build('cool', { mh => $mh, nh => $nh }); +} + +sub generate_rate_page { +# -------------------------------------------------------- +# Creates a Top 10 ratings page. +# + print $IN->header(); + print Links::Build::build('rating', {}); +} + +sub generate_detailed_page { +# -------------------------------------------------------- +# This routine build a single page for every link. +# + my ($page, $id, $link, $detail_match); + + $page = $IN->param('g') || $ENV{PATH_INFO} || ''; + ($id) = $page =~ /(\d+)\Q$CFG->{build_extension}\E$/; + +# Fetch the category info if the link is in multiple categories and the category +# the detailed page was accessed from was passed in. This is done so the next +# and previous links are correct. +# Note that due to the URL transformation (Links::clean_output), it isn't +# possible to pass in the CategoryID unless the detailed url is self generated +# (ie. <%detailed_url%> isn't used). + if ($id) { + my $cat_id = $IN->param('CategoryID'); + if ($cat_id and $DB->table('CatLinks')->count({ LinkID => $id, CategoryID => $cat_id })) { + $link = $DB->table(qw/Links CatLinks Category/)->select({ LinkID => $id, CategoryID => $cat_id })->fetchrow_hashref; + } + else { + $link = $DB->table('Links')->get($id, 'HASH'); + } + } + + if (!$link) { + print "Status: 404" . $GT::CGI::EOL if $CFG->{dynamic_404_status}; + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('PAGE_INVALIDDETAIL', $page) }); + return; + } + + print $IN->header(); + print Links::Build::build('detailed', $link); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Rate.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Rate.pm new file mode 100644 index 0000000..f2a6a4f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Rate.pm @@ -0,0 +1,96 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Rate.pm,v 1.20 2007/12/19 06:59:12 brewt 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 Links::User::Rate; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# --------------------------------------------------- +# Determine what to do. +# + my $id = $IN->param('ID'); + +# Make sure we are allowed to rate it. + if ($CFG->{user_rate_required} and not $USER) { + print $IN->redirect(Links::redirect_login_url('rate')); + return; + } + +# Now figure out what to do. + my $mtl = Links::Build::build('title', Links::language('LINKS_RATE'), "$CFG->{db_cgi_url}/rate.cgi"); + if ($IN->param('rate')) { + my $results = $PLG->dispatch('rate_link', \&rate_it, {}); + $results->{main_title_loop} = $mtl; + if (defined $results->{error}) { + print $IN->header(); + print Links::SiteHTML::display('rate', $results); + } + else { + print $IN->header(); + print Links::SiteHTML::display('rate_success', $results); + } + } + elsif (defined $id and ($id =~ /^\d+$/)) { + print $IN->header(); + my $rec = $DB->table('Links')->get($id); + unless ($rec) { + print Links::SiteHTML::display('error', { error => Links::language('RATE_INVALIDID', $id), main_title_loop => $mtl }); + return; + } + $rec->{detailed_url} = $CFG->{build_detail_url} . '/' . $DB->table('Links')->detailed_url($rec->{ID}) if $CFG->{build_detailed}; + print Links::SiteHTML::display('rate', { %$rec, main_title_loop => $mtl }); + } + else { + print $IN->redirect($IN->param('d') ? "$CFG->{db_cgi_url}/page.cgi?d=1" : $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : ''))); + } +} + +sub rate_it { +# -------------------------------------------------------- +# Give this link a rating. +# + my $id = $IN->param('ID'); + my $rating = $IN->param('rate'); + +# Let's get the link information. + my $links = $DB->table('Links'); + my $rec = $links->get($id); + $rec or return { error => Links::language('RATE_INVALIDID', $id) }; + +# Make sure we have a valid rating. + unless ($rating =~ /^\d\d?$/ and $rating >= 1 and $rating <= 10) { + return { error => Links::language('RATE_INVALIDRATE', $rating), %$rec }; + } + +# Update the rating unless they have already voted. + my $clicktrack = $DB->table('ClickTrack'); + my $rows = $clicktrack->count({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Rate' }); + if ($rows) { + return { error => Links::language('RATE_VOTED', $id), %$rec }; + } + else { + eval { + $clicktrack->insert({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Rate', Created => \'NOW()' }); + + $rec->{Rating} = ($rec->{Rating} * $rec->{Votes} + $rating) / ++$rec->{Votes}; + $links->update({ Rating => $rec->{Rating}, Votes => $rec->{Votes} }, { ID => $rec->{ID} }); + }; + return $rec; + } +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Review.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Review.pm new file mode 100644 index 0000000..d7e168c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Review.pm @@ -0,0 +1,605 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Review.pm,v 1.78 2007/11/16 07:12:57 brewt 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 Links::User::Review; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; + +sub handle { +# ------------------------------------------------------------------ +# Determine what to do. +# + my $input = $IN->get_hash; + if ($input->{add_review}) { $PLG->dispatch('review_add', \&add_review) } + elsif ($input->{edit_review}) { $PLG->dispatch('review_edit', \&edit_review) } + elsif ($input->{helpful}) { $PLG->dispatch('review_helpful', \&helpful_review) } + else { $PLG->dispatch('review_search', \&review_search_results) } + return; +} +# ================================================================== + +sub review_search_results { +# ------------------------------------------------------------------ +# Display a list of validated reviews for a link +# + my $id = shift; + + my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW'), "$CFG->{db_cgi_url}/review.cgi"); + +# Get our form data and prepare some default data. + my $args = $IN->get_hash; + $id ||= $args->{ID}; + $args->{username} = '\*' if $args->{username} eq '*'; + +# Return error if no action + unless ($args->{keyword} or $args->{ReviewID} or $id) { + if ($USER) { + $args->{username} ||= $USER->{Username}; + $IN->param(username => $args->{username}); + } + elsif (!$args->{username} and !$args->{helpful}) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALID_ACTION'), main_title_loop => $mtl }); + return; + } + } + +# Reset ReviewID to null + my $from_helpful = ($args->{helpful}) ? $args->{ReviewID} : ''; + $args->{ReviewID} = ''; + +# Review must be validated to list + $args->{Review_Validated} = 'Yes'; + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : $CFG->{reviews_per_page}; + $args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)$/i) ? $1 : $CFG->{review_sort_order}; + ($args->{sb} and ($args->{sb} =~ /^[\w\s,]+$/) or ($args->{sb} = $CFG->{review_sort_by})); + delete $args->{ma}; + + my $rec = { noLink => 1 }; +# If we are listing reviews of a link + if ($id) { + $id and $args->{ID} = $id; + +# Check if ID is valid + $rec = $DB->table('Links')->get($args->{ID}); + $rec or do { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $args->{ID}), main_title_loop => $mtl }); + return; + }; + $rec = Links::SiteHTML::tags('link', $rec); + $args->{Review_LinkID} = $args->{ID}; + $args->{ww} = 1; + } +# If we have a user to list + elsif ($args->{username}) { + $args->{Review_LinkID} = ''; + $args->{Review_Owner} = $args->{username}; + $args->{'Review_Owner-opt'} = '='; + } + elsif ($IN->param('ReviewID')) { + $args->{ReviewID} = $IN->param('ReviewID'); + $args->{'ReviewID-opt'} = '='; + } + + my $reviews = $DB->table('Reviews'); + my $review_sth = $reviews->query_sth($args); + my $review_hits = $reviews->hits; + +# Return if no results. + unless ($review_hits) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_NORESULTS', $args->{ID} || $args->{username}), main_title_loop => $mtl }); + return; + } + + my @review_results_loop; + Links::init_date(); + my $today = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME); + my %review_cache; + my $last_review = 0; + while (my $review = $review_sth->fetchrow_hashref) { + $review->{Review_Count} = $reviews->count({ Review_LinkID => $review->{Review_LinkID}, Review_Validated => 'Yes' }); + $review->{Review_IsNew} = (GT::Date::date_diff($today, $review->{Review_Date}) < $CFG->{review_days_old}); + if ($CFG->{review_allow_modify} and $USER->{Username} eq $review->{Review_Owner}) { + if ($CFG->{review_modify_timeout}) { + my $oldfmt = GT::Date::date_get_format(); + GT::Date::date_set_format(GT::Date::FORMAT_DATETIME); + my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60); + my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate}; + if (GT::Date::date_is_greater($date, $timeout)) { + $review->{Review_CanModify} = 1; + } + GT::Date::date_set_format($oldfmt); + } + else { + $review->{Review_CanModify} = 1; + } + } + if ($review->{Review_ModifyDate} ne $review->{Review_Date} and $review->{Review_ModifyDate} !~ /^0000-00-00 00:00:00/) { + $review->{Review_ModifyDate} = GT::Date::date_transform($review->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + } + else { + delete $review->{Review_ModifyDate}; + } + $review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + $review->{Num} = $review->{Review_WasHelpful} + $review->{Review_WasNotHelpful}; + ($from_helpful eq $review->{ReviewID}) and $review->{last_helpful} = 1; + $CFG->{review_convert_br_tags} and $review->{Review_Contents} = _translate_html($review->{Review_Contents}); + +# Add the link info to the review + if ($args->{username} or $args->{ReviewID} or $args->{keyword}) { + my $catlink = $DB->table('CatLinks', 'Category', 'Links'); + unless (exists $review_cache{$review->{Review_LinkID}}) { + $review_cache{$review->{Review_LinkID}} = $catlink->get({ LinkID => $review->{Review_LinkID} }); + } + if ($last_review != $review->{Review_LinkID}) { + my $names = $review_cache{$review->{Review_LinkID}}; + $review->{LinkID} = $names->{ID}; + $review->{cat_linked} = sub { Links::Build::build('title_linked', { name => $names->{Full_Name}, complete => 1 }) }; + $review->{cat_loop} = Links::Build::build('title', $names->{Full_Name}); + foreach my $key (keys %$names) { + next if ($key eq 'ID'); + exists $review->{$key} or ($review->{$key} = $names->{$key}); + } + } + $last_review = $review->{Review_LinkID}; + } + push @review_results_loop, $review; + } + + my ($toolbar, %paging); + if ($review_hits > $args->{mh}) { + my $url = $CFG->{db_cgi_url} . "/" . $IN->url; + $url =~ s/([;&?]?)nh=(\d+)/($1 and $1 eq '?') ? '?' : ''/eg; + $url =~ s/[;&]helpful=1//eg; + $toolbar = $DB->html($reviews, $args)->toolbar($args->{nh} || 1, $args->{mh} || 25, $review_hits, $url); + %paging = ( + url => $url, + num_hits => $review_hits, + max_hits => $args->{mh} || 25, + current_page => $args->{nh} || 1 + ); + } + else { + $toolbar = ''; + } + +# Some statistics for review list + my ($review_stats,$review_count); + if (!defined $args->{keyword}) { + if ($args->{username}) { + %$review_stats = map { $_ => $reviews->count({ Review_Owner => $args->{username}, Review_Rating => $_, Review_Validated => 'Yes' }) } (1 .. 5); + $review_count = $reviews->count({ Review_Owner => $args->{username}, Review_Validated => 'Yes'} ); + } + else { + %$review_stats = map { $_ => $reviews->count({ Review_LinkID => $args->{ID}, Review_Rating => $_, Review_Validated => 'Yes' }) } (1 .. 5); + $review_count = $reviews->count({ Review_LinkID => $args->{ID}, Review_Validated => 'Yes'}); + } + if ($review_count) { + for (1 .. 5) { + $review_stats->{'p' . $_} = $review_stats->{$_} * 150 / $review_count; + } + } + } + $review_stats ||= { noStats => 1 }; + + print $IN->header(); + print Links::SiteHTML::display('review_search_results', { + %$review_stats, + %$rec, + show_link_info => ($args->{username} or $args->{ReviewID} or $args->{keyword}), + main_title_loop => $mtl, + Review_Count => $review_hits, + Review_Loop => \@review_results_loop, + Review_SpeedBar => $toolbar, + paging => \%paging + }); + return; +} + +sub add_review { +# ------------------------------------------------------------------ +# Add a review (only logged in users can add reviews if required) +# + my $id = $IN->param('ID') || ''; + + my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW_ADD'), "$CFG->{db_cgi_url}/review.cgi"); + +# Check if we have a valid ID + my $db = $DB->table('Links'); + my $rec = $db->get($id); + unless ($id =~ /^\d+$/ and $rec) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $id), main_title_loop => $mtl }); + return; + } + $rec = Links::SiteHTML::tags('link', $rec); + $rec->{anonymous} = !$CFG->{user_review_required}; + +# Only logged in users can add reviews (if required) or must redirect to the login page + if ($CFG->{user_review_required} and !$USER) { + print $IN->redirect(Links::redirect_login_url('review')); + return; + } + + my ($cat_id, $cat_name) = each %{$db->get_categories($id)}; + my %title = ( + title_loop => Links::Build::build('title', "$cat_name/$rec->{Title}"), + title => sub { Links::Build::build('title_unlinked', "$cat_name/$rec->{Title}") }, + title_linked => sub { Links::Build::build('title_linked', "$cat_name/$rec->{Title}") } + ); + + print $IN->header(); +# If we have a review to add from a form + if ($IN->param('add_this_review')) { + my $results = $PLG->dispatch('add_this_review', \&_add_this_review, $rec); + +# If we have error + if (defined $results->{error}) { + print Links::SiteHTML::display('review_add', { %$results, %$rec, %title, main_title_loop => $mtl }); + } +# Return to add success page + else { + print Links::SiteHTML::display('review_add_success', { %$results, %$rec, %title, main_title_loop => $mtl }); + } + } + else { + if ($USER) { + my $reviews = $DB->table('Reviews'); + my $rc = $reviews->count({ Review_LinkID => $id, Review_Owner => $USER->{Username} }); +# Keep pre 3.2.0 behaviour of allowing the user to edit their existing review + if ($rc == 1 and $CFG->{review_max_reviews} == 1) { + my $review = $reviews->select({ Review_LinkID => $id, Review_Owner => $USER->{Username} })->fetchrow_hashref; + my $oldfmt = GT::Date::date_get_format(); + GT::Date::date_set_format(GT::Date::FORMAT_DATETIME); + my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60); + my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate}; + if (not $CFG->{review_allow_modify} or $review->{Review_Validated} eq 'No' or ($CFG->{review_modify_timeout} and GT::Date::date_is_smaller($date, $timeout))) { + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}), main_title_loop => $mtl }); + } + else { + print Links::SiteHTML::display('review_edit', { + %$rec, %title, confirm => 1, + main_title_loop => Links::Build::build('title', Links::language('LINKS_REVIEW_EDIT'), "$CFG->{db_cgi_url}/review.cgi") + }); + } + GT::Date::date_set_format($oldfmt); + return; + } + elsif ($CFG->{review_max_reviews} and $rc + 1 > $CFG->{review_max_reviews}) { + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}), main_title_loop => $mtl }); + return; + } + } +# We are displaying an add review form + print Links::SiteHTML::display('review_add', { %$rec, %title, main_title_loop => $mtl }); + } +} + +sub _add_this_review { +# ------------------------------------------------------------------ +# Add this review +# + +# Get our form data and some default data. + my $rec = shift; + my $reviews = $DB->table('Reviews'); + my $id = $IN->param('ID'); + my $input = $IN->get_hash; + $input->{Review_LinkID} = $id; + $input->{Review_Validated} = ($CFG->{review_auto_validate} == 1 and $USER or $CFG->{review_auto_validate} == 2) ? 'Yes' : 'No'; + $input->{Review_WasHelpful} = 0 ; + $input->{Review_WasNotHelpful} = 0 ; + $input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none'; + $input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none'; + +# Get the review owner + $input->{Review_Owner} = $USER ? $USER->{Username} : 'admin'; + + if (not $CFG->{user_review_required} and not $USER) { + $input->{Review_GuestName} or return { error => Links::language('REVIEW_GUEST_NAME_REQUIRED') }; + $input->{Review_GuestEmail} or return { error => Links::language('REVIEW_GUEST_EMAIL_REQUIRED') }; + } + +# Make sure we have a valid rating. + my $cols = $reviews->cols; + if (exists $cols->{Review_Rating} and $cols->{Review_Rating}->{not_null} and ($input->{Review_Rating} !~ /^\d$/ or $input->{Review_Rating} < 1 or $input->{Review_Rating} > 5)) { + return { error => Links::language('REVIEW_RATING', $input->{Review_Rating}) }; + } + +# Set date review to today's date. + Links::init_date(); + $input->{Review_Date} = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME); + $input->{Review_ModifyDate} = $input->{Review_Date}; + +# Check that the number of reviews the user owns is under the limit. + if ($USER and $CFG->{review_max_reviews} and + $CFG->{review_max_reviews} < $reviews->count({ Review_LinkID => $id, Review_Owner => $USER->{Username} }) + 1) { + return { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}) }; + } + +# Change the language. + local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL'); + local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE'); + local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL'); + +# Add the review. + # The review will be added only if Review_email_2 is blank + my $added_id = $input->{Review_email_2} ? 1 : $reviews->add($input); + $input->{ReviewID} = $added_id; + unless ($added_id) { + my $error = "
        • " . join("
        • ", $reviews->error) . "
        "; + return { error => $error }; + } + +# Format the date for sending email + $input->{Review_Date} = GT::Date::date_transform($input->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + +# Mail the email. + if ($CFG->{admin_email_review_add}) { + Links::send_email('review_added.eml', { %{$USER || {}}, %$input, %$rec }, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + +# Review added successfully, return to review_add_success page + $CFG->{review_convert_br_tags} and $input->{Review_Contents} = _translate_html($input->{Review_Contents}); + return $input; +} + +sub edit_review { +# ------------------------------------------------------------------ +# Edit a review (only logged in users can edit their reviews) +# + my $id = $IN->param('ID') || ''; + my $rid = $IN->param('ReviewID'); + + my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW_EDIT'), "$CFG->{db_cgi_url}/review.cgi"); + + if (!$CFG->{review_allow_modify}) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MODIFY_DENIED'), main_title_loop => $mtl }); + return; + } + +# Only logged in users can update their reviews or must redirect to the login page + if (!$USER) { + print $IN->redirect(Links::redirect_login_url('review')); + return; + } + +# Check if we have a valid ID + my $db = $DB->table('Links'); + my $rec = $db->get($id); + unless (($id =~ /^\d+$/) and $rec) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $id), main_title_loop => $mtl }); + return; + } + $rec = Links::SiteHTML::tags('link', $rec); + +# If a ReviewID isn't passed in and they have more than one review, then just edit the first review + my $review = $DB->table('Reviews')->select({ Review_LinkID => $id, Review_Owner => $USER->{Username}, $rid ? (ReviewID => $rid) : () })->fetchrow_hashref; + if (!$review) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_NOT_EXISTS', $id), main_title_loop => $mtl }); + return; + } + elsif ($review->{Review_Validated} eq 'No') { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_ADD_WAIT', $id), main_title_loop => $mtl }); + return; + } + +# Has the review modify period passed? + if ($CFG->{review_modify_timeout}) { + my $oldfmt = GT::Date::date_get_format(); + GT::Date::date_set_format(GT::Date::FORMAT_DATETIME); + my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60); + my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate}; + my $smaller = GT::Date::date_is_smaller($date, $timeout); + GT::Date::date_set_format($oldfmt); + if ($smaller) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MODIFY_TIMEOUT', $CFG->{review_modify_timeout}), main_title_loop => $mtl }); + return; + } + } + + my ($cat_id, $cat_name) = each %{$db->get_categories($id)}; + my %title = ( + title_loop => Links::Build::build('title', "$cat_name/$rec->{Title}"), + title => sub { Links::Build::build('title_unlinked', "$cat_name/$rec->{Title}") }, + title_linked => sub { Links::Build::build('title_linked', "$cat_name/$rec->{Title}") } + ); + +# If we have a review to update from a form + if ($IN->param('update_this_review')) { + my $results = $PLG->dispatch('update_this_review', \&_update_this_review, $rec); + +# If we have error + if (defined $results->{error}) { + print $IN->header(); + print Links::SiteHTML::display('review_edit', { %$results, %$rec, %title, main_title_loop => $mtl }); + } +# Return to edit success page + else { + print $IN->header(); + print Links::SiteHTML::display('review_edit_success', { %$results, %$rec, %title, main_title_loop => $mtl }); + } + } +# We are displaying an edit review form + elsif ($IN->param('confirmed')) { + print $IN->header(); + print Links::SiteHTML::display('review_edit', { %$rec, %$review, %title, main_title_loop => $mtl }); + } + +# Else invalid action + else { + return review_search_results(); + } +} + +sub _update_this_review { +# ------------------------------------------------------------------ +# Edit this review +# +# Get our link record. + my $rec = shift; + +# Get our form data and some default data. + my $input = $IN->get_hash; + my $reviews = $DB->table('Reviews'); + my $id = $IN->param('ID'); + $input->{Review_LinkID} = $id; + $input->{Review_Validated} = ($CFG->{review_auto_validate} == 1 and $USER or $CFG->{review_auto_validate} == 2) ? 'Yes' : 'No'; + $input->{Review_WasHelpful} = 0 ; + $input->{Review_WasNotHelpful} = 0 ; + $input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none'; + $input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none'; + +# Get the review owner + $input->{Review_Owner} = $USER->{Username}; + +# Check if this review is valid for this user + my $rows = $reviews->get({ Review_LinkID => $id, Review_Owner => $USER->{Username}, Review_Validated => 'Yes' }); + return { error => Links::language('REVIEW_INVALID_UPDATE') } unless $rows; + +# Make sure we have a valid rating. + my $cols = $reviews->cols; + if (exists $cols->{Review_Rating} and $cols->{Review_Rating}->{not_null} and ($input->{Review_Rating} !~ /^\d$/ or $input->{Review_Rating} < 1 or $input->{Review_Rating} > 5)) { + return { error => Links::language('REVIEW_RATING', $input->{Review_Rating}) }; + } + +# Has the review modify period passed? + if ($CFG->{review_modify_timeout}) { + my $oldfmt = GT::Date::date_get_format(); + GT::Date::date_set_format(GT::Date::FORMAT_DATETIME); + my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60); + my $date = $rows->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $rows->{Review_Date} : $rows->{Review_ModifyDate}; + my $smaller = GT::Date::date_is_smaller($date, $timeout); + GT::Date::date_set_format($oldfmt); + if ($smaller) { + return { error => Links::language('REVIEW_MODIFY_TIMEOUT', $CFG->{review_modify_timeout}) }; + } + } + +# Set date review to today's date. + Links::init_date(); + delete $input->{Review_Date}; + $input->{Review_ModifyDate} = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME); + +# Change the language. + local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL'); + local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE'); + local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL'); + +# Update the record. + $reviews->modify($input, { ReviewID => $input->{ReviewID} }) or return { error => $GT::SQL::error }; + +# Delete the review track from this ReviewID + $DB->table('ClickTrack')->delete({ ReviewID => $input->{ReviewID}, ClickType => 'Review' }) or return { error => $GT::SQL::error }; + +# Format the date for sending email + $input->{Review_Date} = GT::Date::date_transform($input->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + +# Mail the email. + if ($CFG->{admin_email_review_mod}) { + my %tags; + foreach my $key (keys %$rows) { + $tags{"Original_$key"} = $rows->{$key}; + } + foreach my $key (keys %$input) { + $tags{"New_$key"} = $input->{$key}; + } + + Links::send_email('review_modified.eml', { %$USER, %tags, %$rec }, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error"; + } + +# Review added successfully, return to review_add_success page + $CFG->{review_convert_br_tags} and $input->{Review_Contents} = _translate_html($input->{Review_Contents}); + return $input; + +} + +sub helpful_review { +# ------------------------------------------------------------------ +# Review was helpful or not +# + my $reviewID = $IN->param('ReviewID'); + + my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW'), "$CFG->{db_cgi_url}/review.cgi"); + +# Get our Reviews db object + my $db = $DB->table('Reviews'); + my $rec = $db->get($reviewID); + + if (!$rec) { + print $IN->header; + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $rec->{Review_Subject}), main_title_loop => $mtl }); + return; + } + +# Update the rating unless they have already voted. + my $click_db = $DB->table('ClickTrack'); + my $rows = $click_db->count({ ReviewID => $rec->{ReviewID}, IP => $ENV{REMOTE_ADDR}, ClickType => 'Review' }); + if ($rows) { + print $IN->header; + print Links::SiteHTML::display('error', { error => Links::language('REVIEW_VOTED', $rec->{Review_Subject}), main_title_loop => $mtl }); + return; + } + else { + eval { + $click_db->insert({ LinkID => $rec->{Review_LinkID}, ReviewID => $rec->{ReviewID}, IP => $ENV{REMOTE_ADDR}, ClickType => 'Review', Created => \"NOW()" }); +# Update the Timestmp for the link so that the detailed page gets rebuilt with build changed + $DB->table('Links')->update({ Timestmp => \'NOW()' }, { ID => $rec->{Review_LinkID} }); + }; + } + +# Change the language. + local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL'); + local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE'); + local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL'); + +# If this review was helpful + if ($IN->param('yes')) { + if (!$db->update({ Review_WasHelpful => $rec->{Review_WasHelpful} + 1 }, { ReviewID => $reviewID })) { + print $IN->header; + print Links::SiteHTML::display('error', { error => $db->error, main_title_loop => $mtl }); + return; + } + } + else { + if (!$db->update({ Review_WasNotHelpful => $rec->{Review_WasNotHelpful} + 1 }, { ReviewID => $reviewID })) { + print $IN->header; + print Links::SiteHTML::display('error', { error => $db->error, main_title_loop => $mtl }); + return; + } + } + return review_search_results(); +} + +sub _translate_html { +# ------------------------------------------------------------------- +# Translate contents to html format +# + my $html = shift; + $html = GT::CGI::html_escape($html); + $html =~ s,\r?\n,
        ,g; + return $html; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Search.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Search.pm new file mode 100644 index 0000000..7e38972 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Search.pm @@ -0,0 +1,359 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Search.pm,v 1.48 2006/08/08 23:30:09 brewt 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 Links::User::Search; +# ================================================================== +use strict; +use Links qw/:objects/; +use Links::SiteHTML; +use Links::Build; + +my $time_hires; + +sub handle { +#-------------------------------------------------------------------------------- +# Determine whether we are displaying the search form, or doing a +# search. +# + my $db = $DB->table('Links'); + my $results = {}; + my $args = $IN->get_hash; + +# Remove search fields we aren't allowed to search on. + my @bad = (@{$CFG->{search_blocked}}, qw/isValidated ExpiryDate/); + for my $col (@bad) { + $col =~ s/^\s*|\s*$//g; + if ($args->{$col}) { + delete $args->{$col}; + $IN->delete($col); + } + for (qw(lt gt opt le ge ne)) { + delete $args->{"$col-$_"}; + $IN->delete("$col-$_"); + } + } + +# If query is set we know we are searching. + return search() if defined $args->{query} and $args->{query} =~ /\S/; + +# Otherwise, if we pass in a field name, we can search on that too. + foreach (keys %{$db->cols}) { + for my $opt ('', qw/-lt -gt -le -ge -ne/) { + return search() if defined $args->{"$_$opt"} and length $args->{"$_$opt"}; + } + } + + print $IN->header(); + print Links::SiteHTML::display('search', { main_title_loop => Links::Build::build('title', Links::language('LINKS_SEARCH'), "$CFG->{db_cgi_url}/search.cgi") }); +} + +sub search { +# ------------------------------------------------------------------ +# Do the search and print out the results. +# + my $results = $PLG->dispatch('search_results', \&query, {}); + if (defined $results->{error}) { + print $IN->header(); + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_SEARCH'), "$CFG->{db_cgi_url}/search.cgi"); + print Links::SiteHTML::display('search', $results); + } + else { + print $IN->header(); + $results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_SEARCH_RESULTS'), "$CFG->{db_cgi_url}/search.cgi"); + print Links::SiteHTML::display('search_results', $results); + } + if ($CFG->{debug_level} > 1) { + print "
        ", GT::SQL->query_stack_disp , "
        "; + } +} + +sub query { +# ------------------------------------------------------------------ +# Query the database. +# +# First get our search options. + my $args = $IN->get_hash; + if ($args->{query}) { + $args->{query} =~ s/^\s+//; + $args->{query} =~ s/\s+$//; + } + $args->{bool} = (defined $args->{bool} and $args->{bool} =~ /^(and|or)$/i) ? uc $1 : $CFG->{search_bool}; + $args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1; + $args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^\d+$/) ? $args->{mh} : $CFG->{search_maxhits}; + $args->{mh} = 200 if $args->{mh} > 200; # Safety limit + $args->{substring} = defined $args->{substring} ? $args->{substring} : $CFG->{search_substring}; + $args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)$/i) ? $1 : ''; + $args->{sb} and ($args->{sb} =~ /^[\w\s,]+$/ or ($args->{sb} = '')); + delete $args->{ma}; + +# Make sure we only search on validated links. + $args->{isValidated} = 'Yes'; + $args->{ExpiryDate} = '>=' . time if $CFG->{payment}->{enabled}; + + my $query = $args->{query} || ''; + my $term = $IN->escape($query); + + my $links = $DB->table('Links'); + my $categories = $DB->table('Category'); + +# We don't do a category search if we only have a filters. + my $filter = 0; + if (!defined $query or $query eq '') { + $filter = 1; + } + $args->{filter} = $filter; + +# Note: if you use this or the search_set_link_callback, remember to $PLG->action(STOP) or your callback won't be used + $args->{callback} = $PLG->dispatch('search_set_cat_callback', sub { return \&_cat_search_subcat if shift }, $args->{catid}); + my $orig_sb = $args->{sb}; + my $orig_so = $args->{so}; + $args->{sb} = $CFG->{build_sort_order_search_cat}; + $args->{so} = ''; + $filter and $args->{sb} =~ s/\s*,?\s*score//; + + my $started; + if (length $query and $CFG->{search_logging} and $args->{nh} == 1) { + if (!defined $time_hires) { + $time_hires = eval { require Time::HiRes } || 0; + } + $started = $time_hires ? Time::HiRes::time() : time; + } + + my $cat_sth; + $cat_sth = $categories->query_sth($args) unless $filter; + my $cat_count = $filter ? 0 : $categories->hits(); + + $args->{callback} = $PLG->dispatch('search_set_link_callback', sub { return \&_search_subcat if shift }, $args->{catid}); + $args->{sb} = $orig_sb ? $orig_sb : $CFG->{build_sort_order_search} || ''; + $args->{so} = (defined $orig_so and $orig_so =~ /^(asc|desc)$/i) ? $1 : 'ASC'; + $filter and $args->{sb} =~ s/\s*,?\s*score//; + +# Don't force sorting by whether or not a link is paid, as that would make +# searching almost useless w.r.t. unpaid links since a 1% paid match would be +# higher than a 99% unpaid match. + + my $link_sth = $links->query_sth($args); + my $link_count = $links->hits; + +# Log the search if it's a new query + if (length $query and $CFG->{search_logging} and $args->{nh} == 1) { + my $elapsed = ($time_hires ? Time::HiRes::time() : time) - $started; + my $results = $link_count || 0; + my $sl = $DB->table('SearchLogs'); + my $q = lc $query; + substr($q, 255) = '' if length $q > 255; + if (my $row = $sl->select({ slog_query => $q })->fetchrow_hashref) { + my $slog_time = defined $row->{slog_time} + ? ($row->{slog_time} * $row->{slog_count} + $elapsed) / ($row->{slog_count} + 1) + : $elapsed; + $sl->update({ + slog_count => $row->{slog_count} + 1, + slog_time => sprintf('%.6f', $slog_time), + slog_last => time, + slog_hits => $results + }, { + slog_query => $q + }); + } + else { + $sl->insert({ + slog_query => $q, + slog_count => 1, + slog_time => sprintf('%.6f', $elapsed), + slog_last => time, + slog_hits => $results + }) or die "$GT::SQL::error"; + } + } + +# Return if no results. + unless ($link_count or $cat_count) { + return { error => Links::language('SEARCH_NOLINKS', $term), term => $term }; + } + +# Now format the category results. + my $count = 0; + my ($category_results, @category_results_loop); + if (!$filter and $cat_count) { + while (my $cat = $cat_sth->fetchrow_hashref) { + last if ($count++ > $args->{mh}); + my $title = Links::Build::build('title_linked', { name => $cat->{Full_Name}, complete => 1, home => 0 }); + $category_results .= "
      • $title\n"; + $cat->{title_linked} = $title; + $cat->{title_loop} = Links::Build::build('title', $cat->{Full_Name}); + push @category_results_loop, $cat; + } + } + +# And format the link results. + my (@link_results_loop, $link_results, %link_output); + if ($link_count) { + my $results = $link_sth->fetchall_hashref; + $links->add_reviews($results); + @link_results_loop = map Links::SiteHTML::tags('link', $_) => @$results unless $CFG->{build_search_gb}; + if ($CFG->{build_search_gb}) { + my @ids = map { $_->{ID} } @$results; + my $catlink = $DB->table('CatLinks','Category'); + my %names = $catlink->select('LinkID', 'Full_Name', { LinkID => \@ids })->fetchall_list; + foreach my $link (@$results) { + push @{$link_output{$names{$link->{ID}}}}, Links::SiteHTML::tags('link', $link); + } + } + } + +# Join the link results by category if we are grouping. + if ($CFG->{build_search_gb}) { + foreach my $cat (sort keys %link_output) { + $link_output{$cat}->[0]->{title_linked} = sub { Links::Build::build('title_linked', { name => $cat, complete => 1, home => 0 }) }; + $link_output{$cat}->[0]->{title_loop} = Links::Build::build('title', $cat); + push @link_results_loop, @{$link_output{$cat}}; + } + } + $link_results = sub { + my $links; + $CFG->{build_search_gb} or return join("", map { Links::SiteHTML::display('link', $_) } @link_results_loop); + foreach my $cat (sort keys %link_output) { + my $title = Links::Build::build('title_linked', { name => $cat, complete => 1, home => 0 }); + $links .= "

        $title" . join("", map { Links::SiteHTML::display('link', $_) } @{$link_output{$cat}}); + } + return $links; + }; + +# Generate a toolbar if requested. + my ($toolbar, %paging); + if ($link_count > $args->{mh} or $cat_count > $args->{mh}) { + my $url = $CFG->{db_cgi_url} . "/" . $IN->url; + $url =~ s/([;&?]?)nh=(\d+)/($1 and $1 eq '?') ? '?' : ''/eg; + $toolbar = Links::Build::build(search_toolbar => { + url => $url, + numlinks => $link_count > $cat_count ? $link_count : $cat_count, + nh => $args->{nh}, + mh => $args->{mh} + }); + %paging = ( + url => $url, + num_hits => $link_count > $cat_count ? $link_count : $cat_count, + max_hits => $args->{mh}, + current_page => $args->{nh} + ); + } + else { + $toolbar = ''; + } + +# Print the output. + my $results = { + link_results => $link_results, + link_results_loop => \@link_results_loop, + category_results => $category_results, + category_results_loop => \@category_results_loop, + link_hits => $link_count, + cat_hits => $cat_count, + next => $toolbar, + paging => \%paging, + term => $term, + highlight => $CFG->{search_highlighting} + }; + return $results; +} + +sub _search_subcat { +# ------------------------------------------------------------------- +# First argument is the query/table object, second argument is the current +# result set (note: can be quite large). Must return a new result set. +# + my ($query, $results) = @_; + return $results unless (keys %$results); # No matches. + + my $cat_db = $DB->table('Category'); + my $catlink_db = $DB->table('CatLinks', 'Category'); + +# We need the full name of the category. + my @cat_ids = $IN->param('catid') or return $results; + my (@children, %seen); + foreach my $id (@cat_ids) { + next if ($id !~ /^\d+$/); + my $child = $cat_db->children($id) or next; + push @children, @$child, $id; + } + @children or return $results; + @children = grep !$seen{$_}++, @children; + +# Now do the joined query. + my %filtered = map { $_ => $results->{$_} } + $catlink_db->select(LinkID => { CategoryID => \@children, LinkID => [keys %$results] })->fetchall_list; + + return \%filtered; +} + +sub _search_subcat_and { +# ------------------------------------------------------------------- +# Search subcategories using AND. +# + my ($query, $results) = @_; + return $results unless (keys %$results); # No matches + + my $cat_db = $DB->table('Category'); + my $catlink_db = $DB->table('CatLinks', 'Category'); + +# We need the full name of the category. + my @cat_ids = $IN->param('catid') or return $results; + my %final = %$results; + foreach my $id (@cat_ids) { + next unless ($id =~ /^\d+$/); + my @children; + my $childs = $cat_db->children($id); + push @children, @$childs, $id; + my $cond = GT::SQL::Condition->new( + CategoryID => 'IN' => \@children, + LinkID => 'IN' => [ keys %final ] + ); + %final = (); + my $sth = $catlink_db->select($cond, ['LinkID']); + while (my $link_id = $sth->fetchrow_array) { + $final{$link_id} = $results->{$link_id}; + } + last unless keys %final; + } + return \%final; +} + +sub _cat_search_subcat { +# ------------------------------------------------------------------- +# First argument is the query/table object, second argument is the current +# result set (note: can be quite large). Must return a new result set. +# + my ($query, $results) = @_; + return $results unless (keys %$results); # No matches. + + my $cat_db = $DB->table('Category'); + my @cat_ids = $IN->param('catid') or return $results; + my (@children, %seen); + foreach my $id (@cat_ids) { + next if ($id !~ /^\d+$/); + my $child = $cat_db->children($id) or next; + push @children, @$child, $id; + } + @children or return $results; + @children = grep { ! $seen{$_}++ } @children; + + my %subcats = map { $_ => 1 } @children; + my $filtered = {}; + while (my ($k, $s) = each %$results) { + $filtered->{$k} = $s if (exists $subcats{$k}); + } + return $filtered; +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Treecats.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Treecats.pm new file mode 100644 index 0000000..2674a2a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Treecats.pm @@ -0,0 +1,119 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Treecats.pm,v 1.3 2006/09/12 06:07:12 brewt 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. +# ================================================================== + +package Links::User::Treecats; +# ================================================================== +use strict; +use Links qw/:objects/; + +sub handle { +# Fetch these categories (and select them) + my @cid = $IN->param('cid'); +# Fetch these links (and select them) + my @lid = $IN->param('lid'); +# Fetch these categories + my @id = $IN->param('id'); +# Fetch links as well as Categories + my $fetchlinks = $IN->param('links'); + + my $category = $DB->table('Category'); + my $catlinks = $DB->table('CatLinks', 'Links'); + +# Fetching selected categories + if (@cid) { + @lid = (); + @id = @cid; + $fetchlinks = 0; + } +# Fetching selected links + elsif (@lid) { +# Get all the categories that the links are in + @id = $catlinks->select('CategoryID', { LinkID => \@lid }, VIEWABLE)->fetchall_list; + $fetchlinks = 1; + } +# Fetching categories/links + else { + @cid = (); + @lid = (); + @id = (0) unless @id; + } + + my %vars; +# Only allow the use of treecats.cgi if db_gen_category_list == 2 or if +# treecats_enabled (hidden config option) is true + if ($CFG->{db_gen_category_list} != 2 and not $CFG->{treecats_enabled}) { + $vars{error} = 'Permission denied - treecats is currently disabled.'; + } + else { + my @fetchlinks; + my $cond; + if (@cid or @lid) { + my $parents = $category->parents(\@id); + my @ids; + my @fids = (0); + for (keys %$parents) { +# Fetch all the parents and their children + push @ids, @{$parents->{$_}}; + push @fids, @{$parents->{$_}}; +# Fetch the category itself + push @ids, $_; +# When pre-selecting links, @id contains the category the link(s) are in. To +# completely draw the tree, the children of those categories need to be +# retreived as well. + if (@lid) { + push @fids, $_; + push @fetchlinks, $_; + } + push @fetchlinks, @{$parents->{$_}}; + } + $cond = GT::SQL::Condition->new(ID => IN => \@ids, FatherID => IN => \@fids); + $cond->bool('OR'); + } + else { + push @fetchlinks, @id; + $cond = GT::SQL::Condition->new(FatherID => IN => \@id); + } + $category->select_options("ORDER BY Full_Name"); + $vars{categories} = $category->select($cond)->fetchall_hashref; + +# Find the children counts of all the categories and check if they should be selected or not + my @cats; + for (@{$vars{categories}}) { + push @cats, $_->{ID}; + } + $category->select_options("GROUP BY FatherID"); + my %children = $category->select('FatherID', 'COUNT(*)', { FatherID => \@cats })->fetchall_list; + my %selected = map { $_ => 1 } @cid; + for (@{$vars{categories}}) { + $_->{children} = $children{$_->{ID}} || 0; + $_->{selected} = $selected{$_->{ID}} || 0; + } + + if ($fetchlinks and @fetchlinks) { +# Remove CategoryID = 0 (shouldn't normally happen) + @fetchlinks = grep $_, @fetchlinks; + $catlinks->select_options("ORDER BY CategoryID, Title"); + $vars{links} = $catlinks->select({ CategoryID => \@fetchlinks }, VIEWABLE)->fetchall_hashref; + + %selected = map { $_ => 1 } @lid; + for (@{$vars{links}}) { + $_->{selected} = $selected{$_->{ID}} || 0; + } + } + } + + print $IN->header('text/xml'); + print Links::user_page('treecats.xml', \%vars); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/Utils.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Utils.pm new file mode 100644 index 0000000..3158848 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/Utils.pm @@ -0,0 +1,585 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: Utils.pm,v 1.61 2008/07/15 19:50:11 brewt 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 Links::Utils; +# ================================================================== +# This package contains some builtin functions useful in your templates. +# +use strict; +use Links qw/$IN $DB $CFG $USER/; + +sub is_editor { +# ------------------------------------------------------------------- +# Returns true if the current user is an editor. +# + return unless $USER and $USER->{Status} ne 'Not Validated'; + return $DB->table('Editors')->count({ Username => $USER->{Username} }); +} + +sub load_editors { +# ------------------------------------------------------------------- +# You call this tag by placing <%Links::Utils::load_editors%> in your +# category.html template. It will then make available an <%editors%> +# tag that you can use in your template. For example: +# <%Links::Utils::load_editors%> +# <%if editors%> +# The following users are editors in this category: <%editors%> +# <%endif%> +# + my $vars = GT::Template->vars; + my $cat_id = $vars->{category_id} or return "No category_id tag found! This tag can only be used on category.html template"; + my $cat_db = $DB->table('Category'); + my @parents = @{$cat_db->parents($cat_id)}; + push @parents, $cat_id; + + my $ed_db = $DB->table('Editors', 'Users'); + my $sth = $ed_db->select(GT::SQL::Condition->new('CategoryID', 'IN', \@parents)); + return {} unless ($sth->rows); + + # Make any formatting changes you need here. + my $output = '

          '; + my @editors; + my %seen; + while (my $user = $sth->fetchrow_hashref) { + next if ($seen{$user->{Username}}++); + $output .= qq|
        • $user->{Username}
        • |; + push @editors, $user; + } + $output .= "
        "; + return { editors => $output, editors_loop => \@editors }; +} + +sub load_user { +# ------------------------------------------------------------------- +# You call this tag in your link.html or detailed.html template. It will +# provide all the information about the user who owns the link, and also +# create a Contact_Name and Contact_Email tag for backwards compatibility. +# So you would put: +# <%Links::Utils::load_user%> +# This link is owned by <%Username%>, whose email is <%Email%> +# and password is <%Password%>. They are a <%Status%> user. +# + my $vars = GT::Template->vars; + my $username = $vars->{LinkOwner} or return "No LinkOwner tag found! This tag can only be used on link.html or detailed.html templates."; + require Links::Authenticate; + my $user_r = Links::Authenticate->auth('get_user', { Username => $username } ); + return $user_r; +} + +sub load_reviews { +# ------------------------------------------------------------------- +# You call this tag in link.html or detailed.html template. It will +# load all the reviews associated with this link. +# So you would put: +# <%Links::Utils::load_reviews($ID, $max_reviews)%> +# This link has <%Review_Total%> reviews. +# <%loop Reviews_Loop%><%Review_Subject%> - <%Review_ByLine%><%endloop%> +# Review_Count is a deprecated backwards compatible variable +# + my ($id, $max) = @_; + unless ($id) { + my $vars = GT::Template->vars; + $id = $vars->{ID}; + } + my $reviews = $DB->table('Reviews'); + if ($CFG->{review_sort_by}) { + my $order = $CFG->{review_sort_order} || 'DESC'; + $reviews->select_options("ORDER BY $CFG->{review_sort_by} $order"); + } + if ($max and $max =~ /^\d+$/) { + $reviews->select_options("LIMIT $max"); + } + my $review_total = $reviews->count({ Review_LinkID => $id, Review_Validated => 'Yes' }); + my $sth = $reviews->select({ Review_LinkID => $id, Review_Validated => 'Yes' }); + my @reviews; + Links::init_date(); + require Links::User::Review; + my $today = GT::Date::date_get(); + while (my $rev = $sth->fetchrow_hashref) { + $rev->{Review_IsNew} = (GT::Date::date_diff($today, $rev->{Review_Date}) < $CFG->{review_days_old}); + $rev->{Review_CanModify} = 0; + if ($CFG->{review_allow_modify} and $USER->{Username} eq $rev->{Review_Owner}) { + if ($CFG->{review_modify_timeout}) { + my $oldfmt = GT::Date::date_get_format(); + GT::Date::date_set_format(GT::Date::FORMAT_DATETIME); + my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60); + my $date = $rev->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $rev->{Review_Date} : $rev->{Review_ModifyDate}; + if (GT::Date::date_is_greater($date, $timeout)) { + $rev->{Review_CanModify} = 1; + } + GT::Date::date_set_format($oldfmt); + } + else { + $rev->{Review_CanModify} = 1; + } + } + if ($rev->{Review_ModifyDate} ne $rev->{Review_Date} and $rev->{Review_ModifyDate} !~ /^0000-00-00 00:00:00/) { + $rev->{Review_ModifyDate} = GT::Date::date_transform($rev->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + } + else { + delete $rev->{Review_ModifyDate}; + } + $rev->{Review_Date} = GT::Date::date_transform($rev->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format}); + $rev->{Num} = $rev->{Review_WasHelpful} + $rev->{Review_WasNotHelpful}; + $CFG->{review_convert_br_tags} and $rev->{Review_Contents} = Links::User::Review::_translate_html($rev->{Review_Contents}); + push @reviews, $rev; + } + + return { Review_Total => $review_total, Review_Count => scalar @reviews, Review_Loop => \@reviews }; +} + +sub load_link { +# ------------------------------------------------------------------- +# This will return a fully formatted link. Deprecated in favour of +# using load_link_info() + <%include link.html%> +# + my %vars = %{GT::Template->vars}; + if ($Links::GLOBALS) { + delete @vars{keys %$Links::GLOBALS}; + } + return Links::SiteHTML::display('link', \%vars); +} + +sub load_link_info { +# ------------------------------------------------------------------- +# This will return the vars needed to display a fully formatted link (i.e. by +# including link.html) +# + return Links::SiteHTML::tags(link => GT::Template->vars); +} + +sub paging { +# ------------------------------------------------------------------- +# Generate the html needed for a paging toolbar +# +# The paging hash (retrieved from vars) should contain: +# url +# page +# Only one of url or page should be included. +# url is used when the generated url will be <%url%>;nh=<%page_number%> +# page is used when the generated url will be <%build_root_url%>/<%page%>... +# page_format +# 1: <%build_root_url%>/<%page%>{index,more<%current_page%>}.html +# Used in category, cool, new pages +# 2: <%build_root_url%>/<%page%>{,_<%current_page%>}.html +# Used in new page +# num_hits +# max_hits +# current_page +# +# Options: +# max_pages +# The maximum number of pages to display (excluding boundary pages) +# boundary_pages +# When there are more pages than max_pages, this number of boundary +# pages are added to the paging toolbar +# style +# 1: |< < [1 of 20] > >| +# 2: [1 of 20] < > +# 3: |< < 1 2 3 4 5 6 7 8 9 ... 20 > >| +# style_next +# style_prev +# style_first +# style_last +# style_nonext +# style_noprev +# style_nofirst +# style_nolast +# These options allow you to change what's shown for the next/prev/etc +# actions +# lang_of +# For styles 1 and 2, they use the format of " ". +# This option allows you to change the english text of "of". +# lang_button +# For styles 1 and 2, a "Go" button is used for users which do not have +# javascript support. This option allows you to change the button's +# label. +# button_id +# If you've got two paging toolbars on a page, then you will need to +# change the button_id so that the javascript can remove the button. +# paging_pre +# paging_post +# This text or html is added before and after the paging html. +# +# There are two ways of setting the above options: +# 1) Pass them in as arguments +# 2) Create a global code ref named 'paging_options' and return the options +# as a hash reference +# Options passed as arguments override all options passed in via other methods, +# followed by the global options and lastly the defaults contained in this +# function. +# +# Note 1: You can override this function by creating a paging_override global +# Note 2: The arguments to paging_override are slightly different. To keep +# duplicated code to a minimum, %paging with the paging calculations done +# is passed as the first argument (it also contains a few helper code +# refs), and the second argument contains the options with defaults set. +# The left over arguments are the passed in options (shouldn't be needed +# since they have been merged into the options already). +# + my $vars = GT::Template->vars; + + return unless ref $vars->{paging} eq 'HASH'; + my %paging = %{$vars->{paging}}; + return if not $paging{num_hits} or $paging{num_hits} < $paging{max_hits}; + + %paging = ( + page_format => 1, + current_page => 1, + form_hidden => '', + %paging + ); + +# Setup the default options + my %paging_options; + %paging_options = %{$vars->{paging_options}->()} if ref $vars->{paging_options} eq 'CODE'; + my %options = ( + max_pages => 10, + boundary_pages => 1, + style => 1, + style_next => '>', + style_prev => '<', + style_first => '|<', + style_last => '>|', + style_nonext => '', + style_noprev => '', + style_nofirst => '', + style_nolast => '', + lang_of => 'of', + lang_button => 'Go', + button_id => 'paging_button', + paging_pre => '', + paging_post => '', + %paging_options, + @_ + ); + +# Make all the page calculations + $paging{num_pages} = int($paging{num_hits} / $paging{max_hits}); + $paging{num_pages}++ if $paging{num_hits} % $paging{max_hits}; + my ($start, $end); + if ($paging{num_pages} <= $options{max_pages}) { + $start = 1; + $end = $paging{num_pages}; + } + elsif ($paging{current_page} >= $paging{num_pages} - $options{max_pages} / 2) { + $end = $paging{num_pages}; + $start = $end - $options{max_pages} + 1; + } + elsif ($paging{current_page} <= $options{max_pages} / 2) { + $start = 1; + $end = $options{max_pages}; + } + else { + $start = $paging{current_page} - int($options{max_pages} / 2) + 1; + $start-- if $options{max_pages} % 2; + $end = $paging{current_page} + int($options{max_pages} / 2); + } + + my ($left_boundary, $right_boundary); + if ($end >= $paging{num_pages} - $options{boundary_pages} - 1) { + $end = $paging{num_pages}; + } + else { + $right_boundary = 1; + } + + if ($start <= $options{boundary_pages} + 2) { + $start = 1; + } + else { + $left_boundary = 1; + } + + my @pages; + push @pages, 1 .. $options{boundary_pages}, '...' if $left_boundary; + push @pages, $start .. $end; + push @pages, '...', $paging{num_pages} - $options{boundary_pages} + 1 .. $paging{num_pages} if $right_boundary; + $paging{pages} = \@pages; + + $paging{create_link} = sub { + my ($page, $disp) = @_; + my $ret = ''; + $ret .= qq|{build_index_include} ? $CFG->{build_index} : '') : "$CFG->{build_more}$page$CFG->{build_extension}"; + } + elsif ($paging{page_format} == 2) { + $ret .= "_$page" if $page > 1; + $ret .= $CFG->{build_extension}; + } + } + $ret .= qq|">$disp|; + return $ret; + }; + + $paging{select_value} = sub { + my $page = shift; + if ($paging{url}) { + return $page; + } + else { + my $ret = $paging{page}; + if ($paging{page_format} == 1) { + $ret .= $page == 1 ? ($CFG->{build_index_include} ? $CFG->{build_index} : '') : "$CFG->{build_more}$page$CFG->{build_extension}"; + } + elsif ($paging{page_format} == 2) { + $ret .= "_$page" if $page > 1; + $ret .= $CFG->{build_extension}; + } + return $ret; + } + }; + + if ($paging{url}) { +# Figure out what needs to be submitted with the form (it *should* have ? in it +# since with these queries, it *will* have other arguments) + ($paging{form_action}, my $args) = $paging{url} =~ /^(.*?)\?(.*)$/; + NV: for (split /[;&]/, $args) { + my ($name, $val) = /([^=]+)=(.*)/ or next; + $name = $IN->unescape($name); + $val = $IN->unescape($val); + +# Skip these since Links::clean_output will put them in automatically + for (@{$CFG->{dynamic_preserve}}, 'nh') { + next NV if $name eq $_; + } + $paging{form_hidden} .= qq||; + } + $paging{select_name} = 'nh'; + } + else { + $paging{form_action} = "$CFG->{db_cgi_url}/page.cgi"; + $paging{select_name} = 'g'; + } + +# Override this function. Pass in the updated %paging and %options hashes so +# the calculations don't have to be duplicated in the override. + if (ref $vars->{paging_override} eq 'CODE') { + return $vars->{paging_override}->(\%paging, \%options, @_); + } + + my $html; + if ($options{style} == 1) { +# |< < [1 of 20] > >| + $html .= qq|
        $paging{form_hidden}$options{paging_pre}|; + if ($paging{current_page} != 1) { + $html .= $paging{create_link}->(1, $options{style_first}) . ' ' . $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' '; + } + else { + $html .= "$options{style_nofirst} $options{style_noprev} "; + } + + $html .= qq| |; + + if ($paging{current_page} != $paging{num_pages}) { + $html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next}) . ' ' . $paging{create_link}->($paging{num_pages}, $options{style_last}); + } + else { + $html .= "$options{style_nonext} $options{style_nolast}"; + } + $html .= qq|$options{paging_post}
        |; + } + elsif ($options{style} == 2) { +# [1 of 20] < > + $html .= qq|
        $paging{form_hidden}$options{paging_pre} |; + + if ($paging{current_page} != 1) { + $html .= $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' '; + } + else { + $html .= "$options{style_noprev} "; + } + + if ($paging{current_page} != $paging{num_pages}) { + $html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next}); + } + else { + $html .= $options{style_nonext}; + } + $html .= qq|$options{paging_post}
        |; + } + elsif ($options{style} == 3) { +# |< < 1 2 3 4 5 6 7 8 9 ... 20 > >| + $html .= $options{paging_pre}; + if ($paging{current_page} != 1) { + $html .= $paging{create_link}->(1, $options{style_first}) . ' ' . $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' '; + } + else { + $html .= "$options{style_nofirst} $options{style_noprev} "; + } + + for (@{$paging{pages}}) { + if ($_ eq '...') { + $html .= "$_ "; + } + elsif ($_ == $paging{current_page}) { + $html .= "$_ "; + } + else { + $html .= $paging{create_link}->($_, $_) . ' '; + } + } + + if ($paging{current_page} != $paging{num_pages}) { + $html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next}) . ' ' . $paging{create_link}->($paging{num_pages}, $options{style_last}); + } + else { + $html .= "$options{style_nonext} $options{style_nolast}"; + } + $html .= $options{paging_post}; + } + + return \$html; +} + +sub format_title { +# ------------------------------------------------------------------- +# Format a title +# +# Options: +# separator (required) +# The separator used to join the items. +# no_escape_separator +# Set this to a true value if you do not wish to HTML escape the separator. +# include_home +# Whether or not to include Home as the first entry. Default is no. +# include_last +# Whether or not to include the last entry. Default is yes. +# link_type +# How the items should be linked: +# 0: No items linked +# 1: All items linked separately +# 2: All except the last item linked separately +# 3: All items linked as one single link (using the last item's URL) +# no_span +# Don't add the span tags around the last portion of the title. Default is to include the span tags. +# +# Note: You can override this function by creating a format_title_override global +# + my ($title_loop, %options) = @_; + return unless ref $title_loop eq 'ARRAY'; + + my $vars = GT::Template->vars; + if (exists $vars->{format_title_override}) { + return $vars->{format_title_override}->(@_); + } + + if (!exists $options{include_last}) { + $options{include_last} = 1; + } + + if (!$options{include_last}) { + pop @$title_loop; + } + + my $ret; + $options{separator} = GT::CGI::html_escape($options{separator}) unless $options{no_escape_separator}; + for (0 .. $#$title_loop) { + next unless $_ or $options{include_home}; + $ret .= '' if $_ == $#$title_loop and not $options{no_span} and $options{include_last}; + if ($options{link_type} == 1 or + ($options{link_type} == 2 and $_ != $#$title_loop)) { + $ret .= qq|$title_loop->[$_]->{Name}|; + } + else { + $ret .= $title_loop->[$_]->{Name}; + } + $ret .= $options{separator} unless $_ == $#$title_loop; + $ret .= '' if $_ == $#$title_loop and not $options{no_span} and $options{include_last}; + } + if ($options{link_type} == 3) { + $ret = qq|$ret|; + } + return \$ret; +} + +sub column_split { +# ------------------------------------------------------------------- +# Calculate where the columns should be +# + my ($items, $columns) = @_; + if ($items % $columns > 0) { + $items += ($columns - $items % $columns); + } + return $items / $columns; +} + +sub image_url { +# ------------------------------------------------------------------- +# Takes an filename and using the current template set and theme, returns +# the url of the image. It first checks if the file exists in the theme's +# image directory, checks the template's image directory, and then tries +# to check the template inheritance tree for more image directories. +# + my $image = shift; + my ($template, $theme) = Links::template_set(); + + if (-e "$CFG->{build_static_path}/$template/images/$theme/$image") { + return "$CFG->{build_static_url}/$template/images/$theme/$image"; + } + +# Grab the inheritance tree of the template set and grab the basename of +# each template set path (making an assumption that they won't do anything +# crazy with their inheritance). + require GT::File::Tools; + require GT::Template::Inheritance; + my @paths = GT::Template::Inheritance->tree(path => "$CFG->{admin_root_path}/templates/$template", local => 0); + for (@paths) { + my $tpl = GT::File::Tools::basename($_); + next if $tpl eq 'browser'; + if (-e "$CFG->{build_static_path}/$tpl/images/$image") { + return "$CFG->{build_static_url}/$tpl/images/$image"; + } + } + +# The image doesn't exist here, but return it anyway + return "$CFG->{build_static_url}/$template/images/$image"; +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/mod_perl.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Links/mod_perl.pm new file mode 100644 index 0000000..29a9623 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/mod_perl.pm @@ -0,0 +1,113 @@ +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: mod_perl.pm,v 1.34 2005/03/28 22:58:07 brewt 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 Links::mod_perl; +# ================================================================== +use strict(); + +# 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 Links modules into mod_perl:\n\t"; +} + +use Links(); +BEGIN { print STDERR " ." } +use Links::Config(); + +# Preload commonly used GT libs. +use constants(); +use GT::Cache(); +use GT::CGI(); +use GT::Date(); +use GT::Lock; +BEGIN { print STDERR " ." } +use GT::Dumper(); +use GT::FileMan(); +use GT::Mail(); +use GT::Mail::BulkMail(); +use GT::MD5(); +use GT::MD5::Crypt(); +use GT::MIMETypes(); +BEGIN { print STDERR " ." } +use GT::SQL(); +use GT::SQL::Admin(); +use GT::SQL::File(); +use GT::SQL::Relation(); +use GT::SQL::Search(); +use GT::SQL::Display::HTML::Table(); +use GT::SQL::Display::HTML::Relation(); +use GT::SQL::Search::Base::Common(); +use GT::SQL::Search::Base::Indexer(); +use GT::SQL::Search::Base::STH(); +use GT::SQL::Search::Base::Search(); +BEGIN { print STDERR " ." } +use GT::Socket::Client(); +use GT::TempFile(); +use GT::Plugins(); +use GT::Plugins::Author(); +use GT::Plugins::Installer(); +use GT::Plugins::Manager(); +use GT::Template(); +use GT::Template::Editor(); +use GT::Template::Parser(); +use GT::WWW(); +BEGIN { print STDERR " ." } + +# Preload Gossamer Links modules. +use Links::Admin(); +use Links::Authenticate(); +use Links::Bookmark(); +use Links::Browser(); +use Links::Build(); +use Links::Bookmark(); +use Links::Config(); +use Links::Newsletter(); +use Links::Parallel(); +use Links::Payment(); +use Links::Plugins(); +BEGIN { print STDERR " ." } +use Links::SQL(); +use Links::SiteHTML(); +use Links::Tools(); +use Links::Utils(); +use Links::Browser::Controller(); +use Links::Browser::JFunction(); +use Links::Table::Category(); +use Links::Table::Links(); +use Links::Table::Users(); +use Links::HTML::Category(); +use Links::HTML::Links(); +use Links::HTML::Users(); +BEGIN { print STDERR " ." } +use Links::User::Add(); +use Links::User::Editor(); +use Links::User::Jump(); +use Links::User::Login(); +use Links::User::Modify(); +use Links::User::Page(); +use Links::User::Rate(); +use Links::User::Review(); +use Links::User::Search(); + +BEGIN { print STDERR " .\nAll modules loaded ok!\n" } + +print STDERR "Compiling all functions ..."; + +GT::AutoLoader::compile_all(); + +print STDERR " All modules compiled and loaded okay!\n\n"; + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Links/tmp.pl b/site/slowtwitch.com/cgi-bin/articles/admin/Links/tmp.pl new file mode 100644 index 0000000..2eaba96 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Links/tmp.pl @@ -0,0 +1,23 @@ +sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + my $db = $DB->table('Links'); + + my $tags = GT::Template->tags; + my $id = $tags->{ID}; + my $cond = GT::SQL::Condition->new('RelatedArticles','like',$id . "\n%"); + $cond->add('RelatedArticles','like', "%\n" . $id . "\n%"); + $cond->add('RelatedArticles','like', "\n" . $id); + use Data::Dumper; + print Dumper($cond); + #my $sth = $db->select($cond); + + require Links::SiteHTML; + foreach my $id (@ids) { + my $link = $db->get($id); + $link = Links::SiteHTML::tags('link',$link); + push @loop, $link; + } + return { related_articles_loop => \@loop }; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Auth_Facebook.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Auth_Facebook.pm new file mode 100644 index 0000000..45d5031 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Auth_Facebook.pm @@ -0,0 +1,394 @@ +# ================================================================== +# Plugins::Auth_Facebook - Auto Generated Program Module +# +# Plugins::Auth_Facebook +# Author : Gossamer Threads Inc. (Virginia Lo) +# Version : 1.1 +# Updated : Wed Feb 2 10:34:55 2011 +# +# ================================================================== +# + +package Plugins::Auth_Facebook; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; +use vars qw/$TAINTED $GRAPHURL $CALLBACK $AUTHURL $FBMAPPING/; +use GT::WWW; +use GT::JSON; +use Data::Dumper; +use Links::Plugins; + +use open qw(:std :utf8); +use LWP::Simple; +use JSON; +use URI; +use utf8; + +# Inherit from base class for debug and error methods +@Plugins::Auth_Facebook::ISA = qw(GT::Base); + +# Your code begins here. +{ + local $^W = 0; + $TAINTED = substr("$0$^X", 0, 0); +} + +$GRAPHURL = "https://graph.facebook.com"; +$AUTHURL = $GRAPHURL . '/oauth/access_token'; + +$FBMAPPING = { + first_name => 'prof_first_name', + last_name => 'prof_last_name', + email => 'comm_email', +}; + +# PLUGIN HOOKS +# =================================================================== + +sub user_auth { +# ------------------------------------------------------------------- +# ether facebook postback or user call it. + # + my $cfg = Links::Plugins::get_plugin_user_cfg('Auth_Facebook'); + + $CALLBACK = $cfg->{fb_postback_url}; + + my $redirect = $IN->param('url'); + my $ajax = $IN->param('ajax'); + + my $cuser = $USER; +# Check to see if we have the facebook cookie already. + $Links::fbcookie ||= get_facebook_cookie(); + my $code = $IN->param('code'); + my $connect = $IN->param('connect'); + if ($code) { +# --------------------------------------------------------------------- +# User has granted permission to the app to access their information. +# Post a request to facebook to verify the code which can be exchanged for an oauth access token +# --------------------------------------------------------------------- +# If the user authorizes your application, we redirect the user back +# to the redirect URI you specified with a verification string in the +# argument code, which can be exchanged for an oauth access token. +# --------------------------------------------------------------------- + + if ($connect) { + $CALLBACK .= "&connect=1"; + } + my $linkid = $IN->param('linkid'); + if ($linkid) { + $CALLBACK .= "$linkid/"; + } + my $authurl = $AUTHURL . "?client_id=" . $cfg->{fb_appid} . "&redirect_uri=" . GT::CGI::escape($CALLBACK) . "&client_secret=" . $cfg->{fb_secret_key} . "&code=" . $code; + my $res = GT::WWW->post($authurl); + + #print $IN->header; + #print "
        ".  Dumper($res)."
        "; + + if ($res->{content} =~ /access_token=(.+)$/) { +# we got the access token + my $access_token = $1; + $access_token =~ s/\&.+$//g; # Fix it by removing the &epxire=[timestamp] + #print $access_token . "**"; + + my $id = $linkid; + use Plugins::SocialMedia; + my $result = Plugins::SocialMedia::post_facebook($access_token, $id); + #my $result = {}; #Plugins::SocialMedia::post_facebook($access_token, $id); + #print "
        ".  Dumper($id,$result)."
        "; + + if ($result) { + if ($result->{id}) { + $DB->table('Links')->update({ facebook_published => $result->{id} }, { ID => $linkid }); + } + elsif ($result->{error}) { + $DB->table('Links')->update({ facebook_published_message => $result->{error}->{message} }, { ID => $linkid }); + } + $IN->param('t','dev'); #FIXME + require Plugins::SocialMedia; + my $link = Plugins::SocialMedia::format_link($linkid); + print $IN->header; + print Links::user_page('add_success_publish.html', { success => '1', built => 1, %$link }); + return; + } + else { + $IN->param('t','dev'); #FIXME + require Plugins::SocialMedia; + my $link = Plugins::SocialMedia::format_link($id); + print $IN->header; + print Links::user_page('add_success_publish.html', { success => '1', built => 1, %$link }); + return; + } + +=tag +# get the user information + my $userinfo = request_facebook_api('me','email', $access_token); +# check to seee if the user already in community + my $user = user_by_facebook_id($userinfo->{id}); + +# --------------------------------------------------------------------- +# Now then login user with their facebook account +# --------------------------------------------------------------------- + if ($user) { + my $cookies = []; + my $remember = 1; + my $username = $user->{comm_username}; +# create community session. + $user->{session} = comm_create_session( + comm_id => $user->{comm_id}, + remember => $remember, + ip => $ENV{REMOTE_ADDR} + ); +# Get session cookies, and send user to home page or to redirection. + my $session_cookies = Links::session_cookies($user, $remember ? $CFG->{session_remember_expiry} : undef); + push @$cookies, @$session_cookies; + + if ($redirect) { + comm_debug("user |$username| logged in. Redirecting to |$redirect|") if ($CFG->{debug}); + print $IN->header( -url => $redirect, -cookie => $cookies ); + return; + } + else { + $user->{redirect} = $IN->cookie('fb_redirect'); + comm_debug("user |$username| logged in.") if ($CFG->{debug}); + $user->{session_cookie_name_user} = $user->{comm_username}; + $user->{action} = 'login'; + print $IN->header( -cookie => $cookies ); + Links::user_page('user_logged_in.html', { %$user }); + return; + } + } + else { +# --------------------------------------------------------------------- +# Show signup form if they are not in Community but already authorize our app to access their account +# --------------------------------------------------------------------- +# Write the facebook cookies here so that we can access them again after the user +# provides us with username. I don't see where else this is being done. +# --------------------------------------------------------------------- + my $cookies = []; + my $remember = 1; + my $facebook_cookies = facebook_cookies($userinfo, $remember ? $CFG->{session_remember_expiry} : undef); + push @$cookies, @$facebook_cookies; + + if ($connect) { + if (defined $IN->cookie('fb_uid')) { + $userinfo->{facebook_userid} = $IN->cookie('fb_uid'); + } + print $IN->header( -cookie => $cookies ); + Links::user_page('user_connect.html', { fb_user => $userinfo, user => $cuser }); + return; + } + print $IN->header( -cookie => $cookies ); + my @questions; + foreach my $question (@{$CFG->{signup_questions}}) { + push @questions, { question => $question }; + } + my $res = { + comm_question_loop => \@questions, fb_user => $userinfo, fb_signup => 1, + }; + $res->{fancybox} = $IN->param('fancybox') ? 1 : 0; + $res->{iframe} = 1; + $res->{debuginfo} = { cookies => \@$cookies, %$userinfo }; + foreach (keys %$userinfo) { + $res->{querystr} .= "&" if ($res->{querystr}); + $res->{querystr} .= $_ . "=" . $userinfo->{$_}; + } + if ($userinfo->{birthday}) { + ($res->{prof_mon}, $res->{prof_day}, $res->{prof_year}) = split ('/', $userinfo->{birthday}); + $res->{prof_month} =~ s/^0//g; + $res->{prof_day} =~ s/^0//g; + } + Links::user_page('user_signup_fb_popup.html', $res); + return; + } +=cut + } + else { + print $IN->header; + } + } + elsif ($IN->param('error')) { + print $IN->header; + Links::user_page('user_signup_fb_error.html', { error => $IN->param('error') }); + return; + } + else { +# redirect user to facebook and ask for email, offline access, read access +# display=popup mean it's a popup format. + my $cookie = [ + $IN->cookie( + -name => "fb_redirect", + -value => $redirect ? $redirect : '', + -expires => undef, + -path => $CFG->{session_cookie_path} + ) + ]; + if ($IN->param('connect')) { + $CALLBACK .= "&connect=1"; + } + my $linkid = $IN->param('linkid'); + if ($linkid) { + $CALLBACK .= "$linkid/"; + my $tags = $IN->param('twitter_hash_tags'); + my $newtags; + if ($tags) { + $tags =~ s/\s+//g; + my @tags = split(',',$tags); + for (@tags) { + $newtags .= ' #' . $_; + } + } + $DB->table('Links')->update({ facebook_hashtags => $newtags }, { ID => $linkid }) if ($newtags); + } + my $redirurl = 'https://graph.facebook.com/oauth/authorize?client_id=' . $cfg->{fb_appid} . '&redirect_uri=' . GT::CGI::escape($CALLBACK) . '&scope=email,read_stream,publish_stream,manage_pages'; + if (1) { # HAS to have display=popup to show "Log in to Facebook" button + $redirurl .= "&display=popup"; + } + print $IN->header( -url => $redirurl, -cookie => $cookie ); + return; + } +} + +sub request_facebook_api { +# ------------------------------------------------------------------- +# generate facebook api and make a request +# the request results are in json format + # + my ($uid, $type, $token, $publish, $args) = @_; + if (!$token) { + $Links::fbcookie ||= get_facebook_cookie(); + } + + $type ||= "feed"; + + require GT::WWW; + my $content; + my $www = new GT::WWW; +# Note: apparently we need to unescape the token, not escape it. +# perhaps it's a difference between $token and access_token? +# http://drupal.org/node/905164 post #7 as of 9/29/2010 + my $host = $GRAPHURL; + $host =~ s/^(https)?:\/\///g; + $www->protocol($1); + $www->host($host); + if ($publish) { + $www->path("/$uid/feed"); + $www->parameters(access_token => GT::CGI::unescape($token || $Links::fbcookie->{access_token})); + $args ||= $IN->get_hash(); + #use Data::Dumper; print Dumper($args); + for (qw/message picture name caption description link/) { + $www->parameters($_ => GT::CGI::html_escape($args->{$_}), 1) if ($args->{$_} !~ /^\s*$/); + } + $content = $www->post(); + } + else { + my $requestpath = "/" . $uid; + $requestpath .= "/" . $type if ($uid ne 'me'); + $www->path($requestpath); + $www->parameters(access_token => GT::CGI::unescape($token || $Links::fbcookie->{access_token})); + $args ||= $IN->get_hash(); + if ($uid ne 'me') { + for (keys %$args) { + next if ($_ eq 'arg'); + $www->parameters($_ => GT::CGI::html_escape($args->{$_}), 1) if ($args->{$_} !~ /^\s*$/); + } + } + $content = $www->get(); + } + + return unless ($content); + my $data = eval { $content }; + return unless ($data and $data->{content}); + my $res = from_json($data->{content}); + return $res; +} + +sub get_facebook_cookie { +# ------------------------------------------------------------------- +# return facebook cookie in hash if exists + # + my $cfg = Links::Plugins::get_plugin_user_cfg('Auth_Facebook'); + my ($app_id, $application_secret) = ($cfg->{fb_appid}, $cfg->{fb_secret_key}); + my $cookiename = 'fbs_' . $cfg->{fb_appid}; + my $cookies = {}; + + if (defined $ENV{HTTP_COOKIE}) { + for (split /;\s*/, $ENV{HTTP_COOKIE}) { + /(.*)="?(.*)"?/ or next; + my ($key, $val) = (GT::CGI::unescape($1 . $TAINTED), GT::CGI::unescape($2 . $TAINTED)); + if ($_ =~ /(.*)="([^"]+)+"/) { + ($key, $val) = (GT::CGI::unescape($1 . $TAINTED), GT::CGI::unescape($2 . $TAINTED)); + } + $val = [split '&', $val]; + foreach (@$val) { + my ($k, $v) = split /=/, $_; + $cookies->{$key}->{$k} = $v; + } + } + } + + my $args = $cookies->{$cookiename}; + + my $payload; + foreach my $key (sort keys %$args) { + if ($key ne 'sig') { + $payload .= $key . '=' . $args->{$key}; + } + } + require GT::MD5; + my $md5 = GT::MD5::md5_hex($payload . $application_secret); + + return unless ($md5 eq $args->{'sig'}); + return $args; +} + +sub facebook_cookies { +# ------------------------------------------------------------------- +# return facebook cookies, and put it into the cookies list +# in case we need it later. + # + my ($facebookinfo, $expiry) = @_; + $facebookinfo || return; + + my $cookies = [ + $IN->cookie( + -name => "fb_uid", + -value => $facebookinfo ? $facebookinfo->{id} : '', + -expires => $expiry, + -path => $CFG->{session_cookie_path} + ) + ]; + if ($CFG->{session_cookie_domain}) { + push @$cookies, + $IN->cookie( + -name => "fb_uid", + -value => $facebookinfo ? $facebookinfo->{id} : '', + -expires => $expiry, + -path => $CFG->{session_cookie_path}, + -domain => $CFG->{session_cookie_domain} + ); + } + return $cookies; +} + +sub user_by_facebook_id { +# ------------------------------------------------------------------- +# pass in facebook profile id and return the community user +# associated with it if exists. + # + my $uid = shift || return; + my $db = $DB->table('Users'); + return; + my $sth = $db->select( { facebook_userid => $uid }); + if ($sth->rows) { + my $user = $sth->fetchrow_hashref; + return $user; + } + return; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm new file mode 100644 index 0000000..549e7f1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm @@ -0,0 +1,368 @@ +# ================================================================== +# Plugins::ConvertVideo - Auto Generated Program Module +# +# Plugins::ConvertVideo +# Author : Virginia Lo +# Version : 1.1 +# Updated : Wed Feb 21 16:05:27 2007 +# +# ================================================================== +# + +package Plugins::ConvertVideo; + +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/$CFG $IN $DB/; +use Links::Plugins; +use vars qw/$WIDTH $HEIGHT $LINKID $CONVERTBOX $CHECKCONVERTBOX/; + +# Inherit from base class for debug and error methods +@Plugins::ConvertVideo::ISA = qw(GT::Base); + +# Your code begins here! Good Luck! + +# PLUGIN HOOKS +# =================================================================== + +sub validate_link_pre { +# ------------------------------------------------------------------- +# This subroutine will get called whenever the hook 'validate_link' +# is run. You should call GT::Plugins->action (STOP) if you don't +# want the regular code to run, otherwise the code will continue as +# normal. +# + my ($link) = @_; + $link = convert_video($link); + return $link; +} + +sub pre_form_link { +# ------------------------------------------------------------------- +# + my $opts = shift; + if ($opts->{mode} =~ /([add|modify])_form/) { + $CONVERTBOX = 1; + + if ($1 eq 'add') { + $CHECKCONVERTBOX = 1; + } + } + return $opts; +} + +sub post_form_link { +# ------------------------------------------------------------------- +# + my @args = @_; + if (($CONVERTBOX and $IN->param('db') eq 'Links') + || $IN->param('action') eq 'link_add_form' + || $IN->param('action') eq 'link_modify_form') + { + my $checked = ''; + if ($IN->param('action') eq 'link_add_form' || $CHECKCONVERTBOX) { + $checked = ' checked'; + } + + my $font = 'face="Tahoma,Arial,Helvetica" size="2"'; + $args[0] .= +qq~

        + + + +
        Converting Video(s)? YES
        +
        ~; + } + return @args; +} + +sub modify_link_pre { +# ------------------------------------------------------------------- +# This subroutine will get called whenever the hook 'modify_link' +# is run. You should call GT::Plugins->action (STOP) if you don't +# want the regular code to run, otherwise the code will continue as +# normal. +# + my @args = @_; + my $link = $args[0]; + $LINKID = $link->{ID}; + return @args; +} + +sub modify_link_post { +# ------------------------------------------------------------------- +# + my $ret = shift; + if ($ret and $LINKID and $IN->param('admin_convert_video')) { + my $linkdb = $DB->table('Links'); + my $link = convert_video($linkdb->get($LINKID)); + my $res = $linkdb->update($link, { ID => $LINKID }); + if (!$res) { + die "Can't modify link #$LINKID: $GT::SQL::error\n"; + } + } + return $ret; +} + +sub add_link_post { +# ------------------------------------------------------------------- +# + $LINKID = shift; + if ($LINKID) { + &modify_link_post(1); + } + return $LINKID; +} + +sub convert_video { +# ------------------------------------------------------------------ +# Grab video details + my ($link) = @_; + + my $linkid = $link->{ID}; + my $result = { ID => $linkid }; + + my $linksdb = $DB->table('Links'); + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + + my $vf_field = $cfg->{video_file_field}; + my $ff_field = $cfg->{flash_file_field}; + my $thumb = $cfg->{thumbnail_file_field}; + my $image = $cfg->{image_file_field}; + my $url_field = $cfg->{video_url_field}; + + if ($cfg->{flash_dimension} =~ /\s*(\d+)x(\d+)\s*/) { + ($WIDTH, $HEIGHT) = ($1, $2); + } + + my $url = $link->{$url_field}; + if ($url and $url ne '' and $url ne 'http://') { + my $fh = $linksdb->file_info($image, $linkid) or return $result; + + require Plugins::SlideShow; + + # save the Image file (if required) + my $fname = Plugins::SlideShow::get_filename("$fh"); + my $efname = GT::CGI::escape($fname); + + my $main_fpath = $CFG->{admin_root_path} . "/tmp/work-$efname"; + if ($main_fpath ne "$fh") { + open IMG, ">$main_fpath" or return throw_error( $! ); + binmode IMG; + print IMG <$fh>; + close IMG; + } + + my $quality = 75; + + my $image_path = $CFG->{admin_root_path} . "/tmp/image-$efname"; + Plugins::SlideShow::resize_image($main_fpath, $image_path, $WIDTH, $HEIGHT, $quality); + $result->{$image} = GT::SQL::File->open($image_path); + + if ($cfg->{thumbnail_size} =~ /\s*(\d+)x(\d+)\s*/) { + my ($thumb_width, $thumb_height) = ($1, $2); + my $thumb_path = $CFG->{admin_root_path} . "/tmp/thumbnail-$efname"; + Plugins::SlideShow::resize_image($main_fpath, $thumb_path, $thumb_width, $thumb_height, $quality); + $result->{$thumb} = GT::SQL::File->open($thumb_path); + } + return $result; + } + + my $fh = $linksdb->file_info($vf_field, $linkid) or return $result; + + my $full_path = "$fh"; + my $video = {}; + + my $filename = $full_path; + $filename =~ s/(.+)\/\d-([^\/]+)\.$/$2/g; + + my $flv_file_path = + $CFG->{admin_root_path} . "/tmp/" . $linkid . ".flv"; + my $thumb_path = + $CFG->{admin_root_path} . "/tmp/" . "thumbnail-" . $linkid . ".png"; + my $image_path = + $CFG->{admin_root_path} . "/tmp/" . "image-" . $linkid . ".png"; + + my $buf = `ffmpeg -i "$full_path" 2>&1`; + + if ($buf =~ /Video:\s.+\s+(\d+)x(\d+),?.*\s+(\d+)\s+(?:fps|tb)/) { + $video->{width} = $1; + $video->{height} = $2; + $video->{fps} = $3; + + if ($buf =~ /Duration:\s+(\d+):(\d+):(\d+).+bitrate:\s+(\d+)\s+kb\/s/) + { + $video->{duration} = $1 * 3600 + $2 * 60 + $3; + $video->{bitrate} = $4; + } + + } else { + warn "Couldn't get video info"; + return $result; + } + + # Figure out any scaling we might need to do + if ($video->{width} > $WIDTH and $video->{height} > $HEIGHT) { + + # Choose the larger dimension to scale down + if ($video->{width} / $WIDTH > $video->{height} / $HEIGHT) { + $video->{out_height} = + int($video->{height} * $WIDTH / $video->{width}); + $video->{out_width} = $WIDTH; + } else { + $video->{out_width} = + int($video->{width} * $HEIGHT / $video->{height}); + $video->{out_height} = $HEIGHT; + } + } elsif ($video->{width} > $WIDTH) { + $video->{out_height} = int($HEIGHT * $WIDTH / $video->{width}); + $video->{out_width} = $WIDTH; + } elsif ($video->{height} > $HEIGHT) { + $video->{out_height} = $HEIGHT; + $video->{out_width} = int($video->{height} * $WIDTH / $HEIGHT); + } + + # Source dimensions are smaller than output + else { + $video->{out_height} = $video->{height}; + $video->{out_width} = $video->{width}; + } + + $video->{out_height}++ if $video->{out_height} % 2; + $video->{out_width}++ if $video->{out_width} % 2; + + $video->{out_padtop} = int(($HEIGHT - $video->{out_height}) / 2); + $video->{out_padtop}-- if $video->{out_padtop} % 2; + $video->{out_padbottom} = + $HEIGHT - $video->{out_height} - $video->{out_padtop}; + + $video->{out_padleft} = int(($WIDTH - $video->{out_width}) / 2); + $video->{out_padleft}-- if $video->{out_padleft} % 2; + $video->{out_padright} = + $WIDTH - $video->{out_width} - $video->{out_padleft}; + + # Encode the video + system( + "ffmpeg", + '-i', "$full_path", + '-y', # overwrite + # video options + '-vf', "scale=$video->{out_width}:$video->{out_height},pad='$WIDTH:$HEIGHT:$video->{out_padleft}:$video->{out_padtop}'", + + # audio options + '-ar', 22050, # audio sampling rate (Hz) + '-ab', 64, # audio bitrate (kb/s) + '-ac', 2, # audio channels + # encoding options + # '-b', 100000, # video bitrate (b/s) + '-qscale', + $cfg->{flash_quality} || 6, # quality scale (1 [best] - 31 [worst]) + # watermark + # '-vhook', '/usr/lib/vhook/watermark.so -f admin/water3.gif', + # output + "$flv_file_path", + ); + +=tag +# video options + '-r', $video->{fps}, # frame rate + '-s', "$video->{out_width2}x$video->{out_height2}", # frame size + '-padtop', $video->{out_padtop}, + '-padbottom', $video->{out_padbottom}, + '-padleft', $video->{out_padleft}, + '-padright', $video->{out_padright}, +=cut + +# ----------------------------------------------------------------------------------------- +# ----------------------------------------------------------------------------------------- + + # Generate a thumbnail (a quarter of the way through) + my $when = int($video->{duration} * 0.25); + my $hours = int($when / 3600); + my $mins = int($when / 60) - $hours * 60; + my $secs = $when - $hours * 3600 - $mins * 60; + $when = sprintf("%.2d:%.2d:%.2d", $hours, $mins, $secs); + + if ($cfg->{thumbnail_size} and $cfg->{thumbnail_file_field}) { + system( + "ffmpeg", + '-i', "$flv_file_path", + '-y', # overwrite + '-vframes', 1, # record 1 frame + '-ss', $when, + '-an', # no audio + '-vcodec', 'png', + '-f', 'rawvideo', + '-s', $cfg->{thumbnail_size}, + "$thumb_path", + ); + } + + system( + "ffmpeg", + '-i', "$flv_file_path", + '-y', # overwrite + '-vframes', 1, # record 1 frame + '-ss', $when, + '-an', # no audio + '-vcodec', 'png', + '-f', 'rawvideo', + '-s', "${WIDTH}x$HEIGHT", # frame size + "$image_path", + ); + + $result->{$ff_field} = GT::SQL::File->open($flv_file_path); + $result->{$image} = GT::SQL::File->open($image_path); + $result->{$thumb} = GT::SQL::File->open($thumb_path) + if ($cfg->{thumbnail_file_field} and $thumb_path); + + return $result; + +} + +sub get_file_path { +# --------------------------------------------------------------------------- +# return file path of a file column +# + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $id = shift; + my $field_name = shift || "flash_file_field"; + my $field = $cfg->{$field_name}; + my $wantpath = shift || 0; + my $fh = $DB->table('Links')->file_info($field, $id); + return { $field_name . "_path" => '' } if (!$fh); + my $fdir = $fh->File_Directory(); + my $full_path = "$fh"; + my $rel_path = $full_path; + $rel_path =~ s,$fdir,,; + $rel_path =~ s,%,%25,g; + + if ($wantpath) { + return $rel_path; + } + return { $field_name . "_path" => $cfg->{video_url} . $rel_path }; +} + +sub get_flash_dimension { + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $width = 320; + my $height = 240; + if ($cfg->{flash_dimension} =~ /\s*(\d+)x(\d+)\s*/) { + ($width, $height) = ($1, $2); + } + + return { 'video_width' => $width, 'video_height' => $height }; +} + +sub get_video_max_size { + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $field_name = $cfg->{video_file_field}; + my %cols = $DB->table('Links')->_file_cols(); + return $cols{$field_name}->{file_max_size}; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm.old b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm.old new file mode 100644 index 0000000..774910d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/ConvertVideo.pm.old @@ -0,0 +1,336 @@ +# ================================================================== +# Plugins::ConvertVideo - Auto Generated Program Module +# +# Plugins::ConvertVideo +# Author : Virginia Lo +# Version : 1.1 +# Updated : Wed Feb 21 16:05:27 2007 +# +# ================================================================== +# + +package Plugins::ConvertVideo; + +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/$CFG $IN $DB/; +use Links::Plugins; +use vars qw/$WIDTH $HEIGHT $LINKID $CONVERTBOX $CHECKCONVERTBOX/; + +# Inherit from base class for debug and error methods +@Plugins::ConvertVideo::ISA = qw(GT::Base); + +# Your code begins here! Good Luck! + +# PLUGIN HOOKS +# =================================================================== + +sub validate_link_pre { +# ------------------------------------------------------------------- +# This subroutine will get called whenever the hook 'validate_link' +# is run. You should call GT::Plugins->action (STOP) if you don't +# want the regular code to run, otherwise the code will continue as +# normal. +# + my ($link) = @_; + $link = convert_video($link); + return $link; +} + +sub pre_form_link { +# ------------------------------------------------------------------- +# + my $opts = shift; + if ($opts->{mode} =~ /([add|modify])_form/) { + $CONVERTBOX = 1; + + if ($1 eq 'add') { + $CHECKCONVERTBOX = 1; + } + } + return $opts; +} + +sub post_form_link { +# ------------------------------------------------------------------- +# + my @args = @_; + if (($CONVERTBOX and $IN->param('db') eq 'Links') + || $IN->param('action') eq 'link_add_form' + || $IN->param('action') eq 'link_modify_form') + { + my $checked = ''; + if ($IN->param('action') eq 'link_add_form' || $CHECKCONVERTBOX) { + $checked = ' checked'; + } + + my $font = 'face="Tahoma,Arial,Helvetica" size="2"'; + $args[0] .= +qq~

        + + + +
        Converting Video(s)? YES
        +
        ~; + } + return @args; +} + +sub modify_link_pre { +# ------------------------------------------------------------------- +# This subroutine will get called whenever the hook 'modify_link' +# is run. You should call GT::Plugins->action (STOP) if you don't +# want the regular code to run, otherwise the code will continue as +# normal. +# + my @args = @_; + my $link = $args[0]; + $LINKID = $link->{ID}; + return @args; +} + +sub modify_link_post { +# ------------------------------------------------------------------- +# + my $ret = shift; + if ($ret and $LINKID and $IN->param('admin_convert_video')) { + my $linkdb = $DB->table('Links'); + my $link = convert_video({ ID => $LINKID }); + my $res = $linkdb->update($link, { ID => $LINKID }); + if (!$res) { + die "Can't modify link #$LINKID: $GT::SQL::error\n"; + } + } + return $ret; +} + +sub add_link_post { +# ------------------------------------------------------------------- +# + $LINKID = shift; + if ($LINKID) { + &modify_link_post(1); + } + return $LINKID; +} + +sub convert_video { +# ------------------------------------------------------------------ +# Grab video details + my ($link) = @_; + + my $linksdb = $DB->table('Links'); + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + + my $vf_field = $cfg->{video_file_field}; + my $ff_field = $cfg->{flash_file_field}; + my $thumb = $cfg->{thumbnail_file_field}; + my $image = $cfg->{image_file_field}; + + my $fh = $linksdb->file_info($vf_field, $link->{ID}) or return $link; + + my $full_path = "$fh"; + my $video = {}; + + my $filename = $full_path; + $filename =~ s/(.+)\/\d-([^\/]+)\.$/$2/g; + + my $flv_file_path = + $CFG->{admin_root_path} . "/tmp/" . $link->{ID} . ".flv"; + my $thumb_path = + $CFG->{admin_root_path} . "/tmp/" . "thumbnail-" . $link->{ID} . ".png"; + my $image_path = + $CFG->{admin_root_path} . "/tmp/" . "image-" . $link->{ID} . ".png"; + + my $buf = `ffmpeg -i "$full_path" 2>&1`; + + if ($cfg->{flash_dimension} =~ /\s*(\d+)x(\d+)\s*/) { + ($WIDTH, $HEIGHT) = ($1, $2); + } + + if ($buf =~ /Video:.+\s+(\d+)x(\d+),?.*\s+(\d+\.\d+)\s+(?:fps|tb)/) { + $video->{width} = $1; + $video->{height} = $2; + $video->{fps} = $3; + + if ($buf =~ /Duration:\s+(\d+):(\d+):(\d+).+bitrate:\s+(\d+)\s+kb\/s/) + { + $video->{duration} = $1 * 3600 + $2 * 60 + $3; + $video->{bitrate} = $4; + } + + } else { + warn "Couldn't get video info"; + return $link; + } + + # Figure out any scaling we might need to do + if ($video->{width} > $WIDTH and $video->{height} > $HEIGHT) { + + # Choose the larger dimension to scale down + if ($video->{width} / $WIDTH > $video->{height} / $HEIGHT) { + $video->{out_height} = + int($video->{height} * $WIDTH / $video->{width}); + $video->{out_width} = $WIDTH; + } else { + $video->{out_width} = + int($video->{width} * $HEIGHT / $video->{height}); + $video->{out_height} = $HEIGHT; + } + } elsif ($video->{width} > $WIDTH) { + $video->{out_height} = int($HEIGHT * $WIDTH / $video->{width}); + $video->{out_width} = $WIDTH; + } elsif ($video->{height} > $HEIGHT) { + $video->{out_height} = $HEIGHT; + $video->{out_width} = int($video->{height} * $WIDTH / $HEIGHT); + } + + # Source dimensions are smaller than output + else { + $video->{out_height} = $video->{height}; + $video->{out_width} = $video->{width}; + } + + $video->{out_height}++ if $video->{out_height} % 2; + $video->{out_width}++ if $video->{out_width} % 2; + + $video->{out_padtop} = int(($HEIGHT - $video->{out_height}) / 2); + $video->{out_padtop}-- if $video->{out_padtop} % 2; + $video->{out_padbottom} = + $HEIGHT - $video->{out_height} - $video->{out_padtop}; + + $video->{out_padleft} = int(($WIDTH - $video->{out_width}) / 2); + $video->{out_padleft}-- if $video->{out_padleft} % 2; + $video->{out_padright} = + $WIDTH - $video->{out_width} - $video->{out_padleft}; + + # Encode the video + system( + "ffmpeg", + '-i', "$full_path", + '-y', # overwrite + # video options + '-r', $video->{fps}, # frame rate + '-s', "$video->{out_width}x$video->{out_height}", # frame size + '-padtop', $video->{out_padtop}, + '-padbottom', $video->{out_padbottom}, + '-padleft', $video->{out_padleft}, + '-padright', $video->{out_padright}, + + # audio options + '-ar', 22050, # audio sampling rate (Hz) + '-ab', 64, # audio bitrate (kb/s) + '-ac', 2, # audio channels + # encoding options + # '-b', 100000, # video bitrate (b/s) + '-qscale', + $cfg->{flash_quality} || 6, # quality scale (1 [best] - 31 [worst]) + # watermark + # '-vhook', '/usr/lib/vhook/watermark.so -f admin/water3.gif', + # output + "$flv_file_path", + ); + +=tag +# video options + '-r', $video->{fps}, # frame rate + '-s', "$video->{out_width2}x$video->{out_height2}", # frame size + '-padtop', $video->{out_padtop}, + '-padbottom', $video->{out_padbottom}, + '-padleft', $video->{out_padleft}, + '-padright', $video->{out_padright}, +=cut + +# ----------------------------------------------------------------------------------------- +# ----------------------------------------------------------------------------------------- + + # Generate a thumbnail (a quarter of the way through) + my $when = int($video->{duration} * 0.25); + my $hours = int($when / 3600); + my $mins = int($when / 60) - $hours * 60; + my $secs = $when - $hours * 3600 - $mins * 60; + $when = sprintf("%.2d:%.2d:%.2d", $hours, $mins, $secs); + + if ($cfg->{thumbnail_size} and $cfg->{thumbnail_file_field}) { + system( + "ffmpeg", + '-i', "$flv_file_path", + '-y', # overwrite + '-vframes', 1, # record 1 frame + '-ss', $when, + '-an', # no audio + '-vcodec', 'png', + '-f', 'rawvideo', + '-s', $cfg->{thumbnail_size}, + "$thumb_path", + ); + } + + system( + "ffmpeg", + '-i', "$flv_file_path", + '-y', # overwrite + '-vframes', 1, # record 1 frame + '-ss', $when, + '-an', # no audio + '-vcodec', 'png', + '-f', 'rawvideo', + '-s', "${WIDTH}x$HEIGHT", # frame size + "$image_path", + ); + + $link->{$ff_field} = GT::SQL::File->open($flv_file_path); + $link->{$image} = GT::SQL::File->open($image_path); + $link->{$thumb} = GT::SQL::File->open($thumb_path) + if ($cfg->{thumbnail_file_field} and $thumb_path); + + return $link; + +} + +sub get_file_path { +# --------------------------------------------------------------------------- +# return file path of a file column +# + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $id = shift; + my $field_name = shift || "flash_file_field"; + my $field = $cfg->{$field_name}; + my $wantpath = shift || 0; + my $fh = $DB->table('Links')->file_info($field, $id); + return { $field_name . "_path" => '' } if (!$fh); + my $fdir = $fh->File_Directory(); + my $full_path = "$fh"; + my $rel_path = $full_path; + $rel_path =~ s,$fdir,,; + $rel_path =~ s,%,%25,g; + + if ($wantpath) { + return $rel_path; + } + return { $field_name . "_path" => $cfg->{video_url} . $rel_path }; +} + +sub get_flash_dimension { + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $width = 320; + my $height = 240; + if ($cfg->{flash_dimension} =~ /\s*(\d+)x(\d+)\s*/) { + ($width, $height) = ($1, $2); + } + + return { 'video_width' => $width, 'video_height' => $height }; +} + +sub get_video_max_size { + my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo'); + my $field_name = $cfg->{video_file_field}; + my %cols = $DB->table('Links')->_file_cols(); + return $cols{$field_name}->{file_max_size}; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/HandlePage.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/HandlePage.pm new file mode 100644 index 0000000..cd43efd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/HandlePage.pm @@ -0,0 +1,66 @@ +# ================================================================== +# Plugins::HandlePage - Auto Generated Program Module +# +# Plugins::HandlePage +# Author : Gossamer Threads Inc. (Virginia Lo) +# Version : 1.0 +# Updated : Tue Jun 7 15:32:59 2011 +# +# ================================================================== +# + +package Plugins::HandlePage; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; +use Links::SiteHTML; + +# Inherit from base class for debug and error methods +@Plugins::HandlePage::ISA = qw(GT::Base); + +# Your code begins here. + + +# PLUGIN HOOKS +# =================================================================== + + +sub pre_handle_page { +# ----------------------------------------------------------------------------- +# This subroutine will be called whenever the hook 'handle_page' is run. You +# should call $PLG->action(STOP) if you don't want the regular +# 'handle_page' code to run, otherwise the code will continue as normal. +# + my (@args) = @_; + +# Do something useful here + if (my $page2 = $IN->param('page2')) { + $page2 =~ /.+_(\d+).html/; + my $id = $1; + my $linksdb = $DB->table('Links','CatLinks'); + my $link = $linksdb->select( { LinkID => $id })->fetchrow_hashref; + if ($link) { + $link = Links::SiteHTML::tags('link',$link, $link->{CategoryID}); + $link->{detailed_url} =~ /$CFG->{build_root_url}\/(.+)$/; + my $match = $1; + if ($page2 ne $match) { + print $IN->redirect( -url => $link->{detailed_url}, -permanent => 1 ); + #print $IN->header . $page2 . "
        "; + #print $link->{detailed_url} . " ($page2) should be redirected."; + } + } + else { + print "Status: 404" . $GT::CGI::EOL; + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('PAGE_INVALIDDETAIL',$id) }); + } + } + + return @args; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/ConvertVideo.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/ConvertVideo.tar new file mode 100644 index 0000000..474d397 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/ConvertVideo.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/HandlePage.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/HandlePage.tar new file mode 100644 index 0000000..0656cb9 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/HandlePage.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/MostPopular.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/MostPopular.tar new file mode 100644 index 0000000..14746b8 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/MostPopular.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/OverrideModDate.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/OverrideModDate.tar new file mode 100644 index 0000000..0d34066 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/OverrideModDate.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/SlideShow.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/SlideShow.tar new file mode 100644 index 0000000..b82ffa7 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/SlideShow.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/UI.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/UI.tar new file mode 100644 index 0000000..4d92fb5 Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/UI.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/Widgets.tar b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/Widgets.tar new file mode 100644 index 0000000..84c0cdc Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Installed/Widgets.tar differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/MostPopular.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/MostPopular.pm new file mode 100644 index 0000000..88735a8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/MostPopular.pm @@ -0,0 +1,231 @@ +# ================================================================== +# Plugins::MostPopular - Auto Generated Program Module +# +# Plugins::MostPopular +# Author : Virginia Lo +# Version : 1.0 +# Updated : Tue Sep 4 11:23:30 2007 +# +# ================================================================== +# + +package Plugins::MostPopular; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; + +# Inherit from base class for debug and error methods +@Plugins::MostPopular::ISA = qw(GT::Base); + +# Your code begins here. + + +# PLUGIN HOOKS +# =================================================================== + + +sub jump_link { +# ----------------------------------------------------------------------------- +# This subroutine will be called whenever the hook 'jump_link' is run. You +# should call $PLG->action(STOP) if you don't want the regular +# 'jump_link' code to run, otherwise the code will continue as normal. +# + $PLG->action(STOP); + my $links = $DB->table('Links'); + my $id = $IN->param('ID') || $IN->param('Detailed'); + my $action = $IN->param('action') || ''; + my $goto = ''; + my $rec = {}; + + if ($CFG->{framed_jump} and $id and $action eq 'jump_frame') { + my $error; + if ($id !~ /^\d+$/) { + $error = Links::language('JUMP_INVALIDID', $id); + } + else { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + unless ($rec) { + $error = Links::language('JUMP_INVALIDID', $id); + $rec = {}; + } + elsif ($CFG->{build_detailed}) { + $rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id); + } + } + print $IN->header(); + print Links::SiteHTML::display('jump_frame', { error => $error, %$rec }); + return; + } + +# If we are chosing a random link, then get the total and go to one at random. + if (lc $id eq "random") { + my $offset = int rand $links->count(VIEWABLE); + $links->select_options("LIMIT 1 OFFSET $offset"); + my $sth = $links->select(qw/ID URL/ => VIEWABLE); + ($id, $goto) = $sth->fetchrow_array; + } + elsif (defined $id) { + if ($id !~ /^\d+$/) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + +# Find out if we're going to be displaying a file + my $col = $IN->param('v') || $IN->param('dl') || $IN->param('view') || $IN->param('download'); + + if ($col) { +# in this case, we need to know from what table we want to load our data from. +# It will by default pull information from the Links table, however if the +# DB=tablename option is used, it will apply the request to that table instead + my $table_name = $IN->param('DB') || 'Links'; + + unless ($table_name =~ m/^\w+$/) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLEFORMAT' ) }); + return; + }; + + if ($table_name ne 'Links') { + eval { $links = $DB->table($table_name) }; + if ($@) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLE', $table_name, $GT::SQL::error) }); + return; + } + } + + my $fh; + eval { $fh = $links->file_info($col, $id); }; + if ($fh) { + if ($IN->param('v') or $IN->param('view')) { # Viewing + print $IN->header($IN->file_headers( + filename => $fh->File_Name, + mimetype => $fh->File_MimeType, + inline => 1, + size => $fh->File_Size + )); + } + else { # Downloading + print $IN->header($IN->file_headers( + filename => $fh->File_Name, + mimetype => $fh->File_MimeType, + inline => 0, + size => $fh->File_Size + )); + } + binmode $fh; + while (read($fh, my $buffer, 65536)) { + print $buffer; + } + return 1; + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('FILE_UNKNOWN', $id) }); + return; + } + } +# Jump to a URL, bump the hit counter. + else { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + unless ($rec) { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + $goto = $rec->{URL}; + + my $clicktrack = $DB->table('ClickTrack'); + my $customdb = $DB->table('ClickTrack_Custom'); + + my $rows = $clicktrack->count({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits' }); + unless ($rows) { + eval { + $clicktrack->insert({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits', Created => \"NOW()" }); + $customdb->insert({ click_linkid => $id, click_date => \"NOW()" }); + $links->update({ Hits => \"Hits + 1", Timestmp => $rec->{Timestmp} }, { ID => $id }, { GT_SQL_SKIP_INDEX => 1 }); + }; + } + } + } +# Oops, no link. + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } + +# Redirect to a detailed page if requested. + if ($CFG->{build_detailed} and $IN->param('Detailed')) { + $goto = Links::transform_url("$CFG->{build_detail_url}/" . $links->detailed_url($id)); + } + ($goto =~ m,^\w+://,) or ($goto = "http://$goto"); + + unless (defined $goto) { + my $error = ($IN->param('ID') eq 'random') ? Links::language('RANDOM_NOLINKS') : Links::language('JUMP_INVALIDID', $id); + print $IN->header(); + print Links::SiteHTML::display('error', { error => $error }); + return; + } + + if ($goto) { + if ($CFG->{framed_jump} and not ($CFG->{build_detailed} and $IN->param('Detailed'))) { + unless (keys %$rec) { + $rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref; + } + $rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id) if $CFG->{build_detailed}; + print $IN->header(); + print Links::SiteHTML::display('jump', { destination => $goto, %$rec }); + return; + } + else { + print $IN->redirect($goto); + } + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) }); + return; + } +} + +sub generate_popular_links { + my $mh = shift || 5; + if ($GLinks::MOSTPOP) { + return $GLinks::MOSTPOP; + } + + my $today = GT::Date::date_get(); + require Links::Plugins; + my $cfg = Links::Plugins::get_plugin_user_cfg('MostPopular'); + my $last_x_days = $cfg->{last_x_days} || 14; + my $from_date = GT::Date::date_sub($today, $last_x_days); + my $to_date = GT::Date::date_sub($today, 0); + require GT::SQL::Condition; + #my $cond = GT::SQL::Condition->new('click_date', '>=', $from_date, 'click_date','<=', $to_date); + my $cond = GT::SQL::Condition->new('Mod_Date', '>=', $from_date, 'Mod_Date','<=', $to_date); + #my $db = $DB->table('ClickTrack_Custom'); + my $db = $DB->table('Links'); + my $linksdb = $DB->table('Links'); + use Data::Dumper; + #$db->select_options('GROUP by click_linkid','ORDER BY count desc',"Limit $mh"); + $db->select_options('ORDER BY Hits DESC',"Limit $mh"); + #my $sth = $db->select($cond, ['count(*) as count', 'click_linkid']); + my $sth = $db->select($cond, ['ID']); + my @loop; + while (my $row = $sth->fetchrow_hashref()) { + my $link = $linksdb->get($row->{ID}); + $link = Links::SiteHTML::tags('link',$link); + push @loop, { %$link, %$row }; + } + + $GLinks::MOSTPOP = { MostPopularLinks => \@loop, FromDate => $from_date, ToDate => $to_date }; + return $GLinks::MOSTPOP; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/NewestReviews.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/NewestReviews.pm new file mode 100644 index 0000000..deffe13 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/NewestReviews.pm @@ -0,0 +1,47 @@ +# ================================================================== +# Plugins::NewestReviews - Auto Generated Program Module +# +# Plugins::NewestReviews +# Author : Jordan Rapp +# Version : 1.0 +# Updated : Wed Sep 11 20:07:11 2008 +# +# ================================================================== +# + +package Plugins::NewestReviews; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; + +# Inherit from base class for debug and error methods +@Plugins::NewestReviews::ISA = qw(GT::Base); + +# Your code begins here. + + +# PLUGIN HOOKS +# =================================================================== + +sub generate_newest_reviews { + my $mh = shift || 5; + require Links::Plugins; + #my $cfg = Links::Plugins::get_plugin_user_cfg('MostPopular'); + my $db = $DB->table('Reviews'); + my $linksdb = $DB->table('Links'); + use Data::Dumper; + my $sth = $db->do("SELECT Review_Subject, Review_LinkID FROM glinks_Reviews WHERE Review_Validated = 'Yes' ORDER BY Review_Date DESC LIMIT 5"); + my @loop; + while (my $row = $sth->fetchrow_hashref()) { + my $link = $linksdb->get($row->{Review_LinkID}); + $link = Links::SiteHTML::tags('link',$link); + push @loop, { %$link, %$row }; + } + return { NewestReviewsLinks => \@loop }; +} + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/OverrideModDate.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/OverrideModDate.pm new file mode 100644 index 0000000..7bb9844 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/OverrideModDate.pm @@ -0,0 +1,153 @@ +# ================================================================== +# Plugins::OverrideModDate - Auto Generated Program Module +# +# Plugins::OverrideModDate +# Author : Gossamer Threads Inc. +# Version : 1.0 +# Updated : Mon Sep 24 14:34:23 2007 +# +# ================================================================== +# + +package Plugins::OverrideModDate; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; + +# Inherit from base class for debug and error methods +@Plugins::OverrideModDate::ISA = qw(GT::Base); + +# Your code begins here. + + +# PLUGIN HOOKS +# =================================================================== + +sub post_modify_link { +# ------------------------------------------------------------------- +# Modify a single link. +# + my $ret = shift; + return $ret if (!$ret); + + my $new = {}; + my $update = 0; + Links::init_date(); + if ($IN->param('Add_Date') =~ /^\d\d\d\d-\d\d-\d\d$/) { + $new->{Add_Date} = $IN->param('Add_Date'); + $update = 1; + } + if ($IN->param('Mod_Date') =~ /^\d\d\d\d-\d\d-\d\d$/) { + $new->{Mod_Date} = $IN->param('Mod_Date'); + $update = 1; + } + my $id = $IN->param('ID') || $IN->param('LinkID'); + if ($id and $update) { + $DB->table('Links')->update({ %$new }, { ID => $id }); + } + + return $ret; +} + +sub pre_handle { +# --------------------------------------------------- +# Determine what to do. +# + my @args = @_; + my $link_id = $IN->param('LinkID'); + if ($CFG->{user_required} and !$USER) { + $PLG->action(STOP); + print $IN->redirect(Links::redirect_login_url('modify')); + return @args; + } + +# Perform the link modification + if ($IN->param('modify')) { + return @args; + } + elsif ($USER) { +# Display the link modify form (for a specific link) + if ($IN->param('LinkID')) { + $PLG->action(STOP); + _modify_passed_in(); + } + } + return @args; +} + +sub _modify_passed_in { +# -------------------------------------------------------- +# Display link that was passed in. +# + my $lid = $IN->param('LinkID'); + my $link_db = $DB->table('Links'); + my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi?LinkID=$lid"); + my $sth = $link_db->select({ ID => $lid, LinkOwner => $USER->{Username} }, VIEWABLE); + if ($USER->{Status} eq 'Administrator') { + $sth = $link_db->select({ ID => $lid }, VIEWABLE); + } + if ($sth->rows) { + my $link = $sth->fetchrow_hashref; + my @ids = $DB->table('CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list; + $IN->param('CatLinks.CategoryID', \@ids); + + $link->{Contact_Name} ||= $USER->{Name} || $USER->{Username}; + $link->{Contact_Email} ||= $USER->{Email}; + + my $category = {}; + if ($CFG->{db_gen_category_list} < 2) { + require Links::Tools; + $category = Links::Tools::category_list(); + $category->{Category} = sub { Links::Tools::category_list_html() }; + } + print $IN->header(); + print Links::SiteHTML::display('modify', { + main_title_loop => $mtl, + %$link, + %$category + }); + } + elsif (!$CFG->{user_required}) { + require Links::User::Modify; + Links::User::Modify::_modify_form(); + } + else { + print $IN->header(); + print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOTOWNER'), LinkID => $lid, main_title_loop => $mtl }); + } +} + +sub post_add_link { +# ------------------------------------------------------------------- +# Modify a single link. +# + my $ret = shift; + return $ret if (!$ret); + + my $new = {}; + my $update = 0; + Links::init_date(); + if ($IN->param('Add_Date') =~ /^\d\d\d\d-\d\d-\d\d$/) { + $new->{Add_Date} = $IN->param('Add_Date'); + $update = 1; + } + if ($IN->param('Mod_Date') =~ /^\d\d\d\d-\d\d-\d\d$/) { + $new->{Mod_Date} = $IN->param('Mod_Date'); + $update = 1; + } + my $id = $ret->{ID}; + if ($id and $update) { + $DB->table('Links')->update({ %$new }, { ID => $id }); + } + + return $ret; +} + + +# Always end with a 1. +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SlideShow.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SlideShow.pm new file mode 100644 index 0000000..07eb9da --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SlideShow.pm @@ -0,0 +1,1953 @@ +# ================================================================== # Plugins::SlideShow - Auto Generated Program Module +# +# Plugins::SlideShow +# Author : Gossamer Threads Inc. +# Version : $Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $ +# Updated : Tue Nov 27 17:18:24 2001 +# +# ================================================================== +# + +package Plugins::SlideShow; +# ================================================================== + + use strict; + use GT::Base; + use GT::Plugins qw/STOP CONTINUE/; + use Links qw/$CFG $IN $DB/; + use Links::Plugins; + use GT::CGI; + use GT::AutoLoader; + use vars qw/@image_types/; + + # Inhert from base class for debug and error methods + @Plugins::SlideShow::ISA = qw/GT::Base/; + + @image_types = qw/thumbnail medium large largest/; + + +sub check_input { +# ------------------------------------------------------------------- +# This checks the modify input to ensure that all +# image files comply with the settings in the plugin +# + my $p = $IN->get_hash; + + my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow'); + my ( $max_width, $max_height, $image_cols, $temp_dir ) = + map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |; + + my @image_cols = grep $_, map { s,^\s*|\s*$,,g; $_ } split /,/, $image_cols; + + require GT::SQL::File; + # is there an image to deal with? + foreach my $image_col (@image_cols) { + + my $fh = $p->{$image_col}; + ref $fh or next; + my $fname = get_filename("$fh"); + $fname =~ s/\s+/_/g; + my $efname = GT::CGI::escape($fname); + + # save the Image file (if required) + my $main_fpath = "$temp_dir/$efname"; + if ( $main_fpath ne "$fh" ) { + open IMG, ">$main_fpath" or do { + GT::Plugins->action( STOP ); + return { error => $! }; + }; + binmode IMG; + print IMG <$fh>; + close IMG; + } + + # make sure it fits within the bounds + if (my $max_size = $cfg->{max_upload_size}) { + if ($max_size <= -s $main_fpath) { + unlink $main_fpath; + GT::Plugins->action( STOP ); + return { error =>"Image in '$image_col' too large" }; + } + } + if (my $max_dim = $cfg->{max_upload_constraints}) { + if ($max_dim =~ /(\d+)\s*x\s*(\d+)/) { + my ($max_dim_width, $max_dim_height) = ($1, $2); + my ($im_width, $im_height) = imgsize($main_fpath); + if ($max_dim_width < $im_width) { + unlink $main_fpath; + GT::Plugins->action( STOP ); + return { error => "Image in '$image_col' is too wide" }; + } + if ($max_dim_height < $im_height) { + unlink $main_fpath; + GT::Plugins->action( STOP ); + return { error => "Image in '$image_col' is too tall" }; + } + } + } + + # now setup the record to save + $IN->param( $image_col, GT::SQL::File->open( $main_fpath ) ); + } + + return @_; +} + +sub modify_link { +# ------------------------------------------------------------------- +# This subroutine will get called whenever the hook 'add_link' +# is run. You should call GT::Plugins->action ( STOP ) if you don't +# want the regular code to run, otherwise the code will continue as +# normal. +# + my ($p) = @_; + + my $cfg = Links::Plugins->get_plugin_user_cfg( 'SlideShow' ); + my ( $max_width, $max_height, $image_cols, $temp_dir ) = + map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |; + + my @image_cols = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $image_cols; + + my $err = ''; + + require GT::SQL::File; + # is there an image to deal with? + foreach my $image_col (@image_cols) { + my $fh = $p->{$image_col}; + + # Is the user trying to delete the image? + # If so, just delete all the other images + if ( $p->{$image_col . "_del"} ) { + for my $types (@image_types) { + $p->{$image_col."_${types}_del"} = "delete"; + } + } + + ref $fh or next; + my $fname = get_filename("$fh"); + $fname =~ s/\s+/_/g; + my $efname = GT::CGI::escape($fname); + + # save the Image file (if required) + my $main_fpath = "$temp_dir/work-$efname"; + if ($main_fpath ne "$fh") { + open IMG, ">$main_fpath" or return throw_error( $! ); + binmode IMG; + print IMG <$fh>; + close IMG; + } + + # make sure it fits within the bounds + if (my $max_size = $cfg->{max_upload_size}) { + if ($max_size <= -s $main_fpath) { + unlink $main_fpath; + return throw_error( "Image in '$image_col' too large" ); + } + } + if (my $max_dim = $cfg->{max_upload_constraints}) { + if ($max_dim =~ /(\d+)\s*x\s*(\d+)/) { + my ($max_dim_width, $max_dim_height) = ($1, $2); + my ($im_width, $im_height) = imgsize($main_fpath); + + if ($max_dim_width < $im_width) { + unlink $main_fpath; + return throw_error("Image in '$image_col' is too wide"); + } + if ($max_dim_height < $im_height) { + unlink $main_fpath; + return throw_error("Image in '$image_col' is too tall"); + } + } + } + + my $type_index = ($cfg->{'link_type_2'} eq $p->{Link_Type}) ? 2 : 1; + my $quality = $cfg->{"image_quality"}; + foreach my $col (@image_types) { + my $constraints = $cfg->{"${col}_constraints_${type_index}"} or next; + my ($crop, $mx, $my) = $constraints =~ /(crop\s*)?(\d+)\s*[,x]\s*(\d+)/; + my $thumb_fpath = "$temp_dir/${col}_$efname"; + + if ($crop) { + crop_resize_image($main_fpath, $thumb_fpath, $mx, $my, $quality); + } + else { + resize_image($main_fpath, $thumb_fpath, $mx, $my, $quality); + } + + $p->{"${image_col}_${col}"} = GT::SQL::File->open($thumb_fpath); + + # If the image is large enough to support it, add the watermark + if (my $water_fpath = $cfg->{watermark_path} and $mx > 100 and $my > 100) { + apply_watermark($thumb_fpath, $water_fpath); + } + } + + # apply watermarks to main image + if (my $water_fpath = $cfg->{watermark_path}) { + apply_watermark($main_fpath, $water_fpath); + } + + # now setup the record to save + $p->{$image_col} = GT::SQL::File->open($main_fpath); + } + + # delete the image cache so that it will be rebuilt next run through + $p->{SlideShowCache} = ''; + + return @_; +} + +sub add_link { + modify_link(@_) +} + +sub get_filename($) { +# ------------------------------------------------------------------- + my $fpath = shift; + my @path = split m#(?:/|\\)#, $fpath; + return pop @path; +} + +sub generate_paths { +#------------------------------------------------------------------------------- +# this method is used by the templates to generate all the paths that +# are required to have a direct point to the image file, this ensures that +# the images are not downloaded via the cgi, because the cgi puts an +# inordinate amount of load on the server +# + my $conf = Links::Plugins::get_plugin_user_cfg( 'SlideShow' ); + my @image_cols = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $conf->{image_cols}; + my $tags = $_[1] ? $_[1] : GT::Template->tags; + my $vars = {}; + my $linkid = ( shift || $tags->{ID} ) or return; + + my $rec = ( $tags->{ID} == $linkid and $tags->{SlideShowCache} ) + ? { SlideShowCache => $tags->{SlideShowCache} } + : $Links::DB->table( "Links" )->get( $linkid ); + + my $cache_dump = $vars->{SlideShowCache} || $rec->{SlideShowCache} || '{}'; + + my $cached = ( eval $cache_dump ) || {}; + my $changed = 0; + my ($linksdb, $linkscols); + my @imgs_loop; + + foreach my $img_col (@image_cols) { + if ( # if one has been wiped out + $cached->{unchanged}{$img_col} xor $rec->{$img_col} or + # if one has been changed + $cached->{unchanged}{$img_col} ne $rec->{$img_col} or + # if the cache contains nothing but the column does + (not exists $cached->{$img_col} and $rec->{$img_col}) + ) { + $cached->{unchanged}{$img_col} = $rec->{$img_col}; + $changed = 1; + foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) { + my $base_col = $img_col . $coltype; + + $linksdb ||= $Links::DB->table( 'Links' ); + $linkscols ||= $linksdb->cols; + + next unless defined $linkscols->{$base_col}; + + my $fh = $linksdb->file_info($base_col, $linkid) or next; + my $fdir = $fh->File_Directory(); + my $full_path = "$fh"; + my $rel_path = $full_path; + $rel_path =~ s,$fdir,,; + $rel_path =~ s,%,%25,g; + + if (-f $full_path) { + my ($width, $height) = imgsize($full_path); + $vars->{"${base_col}_height"} = $cached->{extra}{"${base_col}_height"} = $height; + $vars->{"${base_col}_width"} = $cached->{extra}{"${base_col}_width"} = $width; + }; + + $vars->{"${base_col}_path"} = $cached->{$base_col} = $rel_path ? qq!$conf->{image_url_path}$rel_path! : ''; + } + } + else { + foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) { + my $base_col = $img_col . $coltype; + $vars->{"${base_col}_path"} = $cached->{$base_col} || ''; + $vars->{"${base_col}_path"} =~ s,^http://www.slowtwitch.com\/,\/,; + $vars->{"${base_col}_width" } = $cached->{extra}{"${base_col}_width"} || ''; + $vars->{"${base_col}_height" } = $cached->{extra}{"${base_col}_height"} || ''; + } + } + + next unless $cached->{$img_col}; + + my $img_loop_element = { + col_name => $img_col, + description => $rec->{$img_col."_description"} + }; + + foreach my $coltype ('', qw( _thumbnail _medium _large _largest )) { + $img_loop_element->{"${coltype}_path"} = $cached->{"${img_col}${coltype}"}; + $img_loop_element->{"${coltype}_path"} =~ s,^http://www.slowtwitch.com\/,\/,i; + $img_loop_element->{"${coltype}_width"} = $cached->{extra}{"${img_col}${coltype}_width"}; + $img_loop_element->{"${coltype}_height"} = $cached->{extra}{"${img_col}${coltype}_height"}; + } + + push @imgs_loop, $img_loop_element; + } + + if ($changed) { + $linksdb ||= $Links::DB->table('Links'); + require GT::Dumper; + my $cache_dump = GT::Dumper->dump(data => $cached, var => ''); + + my $update_sth = $linksdb->prepare( + "UPDATE ".$linksdb->name." SET SlideShowCache = ? WHERE ID = ?" + ); + $update_sth->execute($cache_dump, $linkid) + or warn "Couldn't update Link ID: $linkid because $GT::SQL::error"; + } + + $vars->{image_loop} = $vars->{images_loop} = \@imgs_loop if @imgs_loop; + + return $vars; +} + +sub field_management { + Plugins::SlideShow->_field_management(@_); +} + +sub _field_management; +$COMPILE{_field_management} = __LINE__ . <<'END_OF_SUB'; +sub _field_management { +# -------------------------------------------------- + # get rid of the class name + my $junk = shift; + my $conf = Links::Plugins::get_plugin_user_cfg('SlideShow'); + + my $ltbl = $DB->table('Links'); + my $lcols = $ltbl->cols; + + my @thumbnail_fields = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $conf->{image_cols}; + + my @errors; + my $tags = {}; + + # register all the file save in locations + my %file_save_in; + + my @columns; + + foreach my $col (@thumbnail_fields) { + push @columns, $col; + push @columns, map { $conf->{"${_}_constraints_1"} ? "${col}_${_}" : () } @image_types; + push @columns, map { $conf->{"${_}_constraints_2"} ? "${col}_${_}" : () } @image_types; + push @columns, "${col}_description"; + } + + foreach my $col (@columns) { + next if ($col =~ /_description$/); + my $col_info = $lcols->{$col} or next; + push @{$file_save_in{$col_info->{file_save_in}}}, $col; + } + + my ($create_file_save_in, $create_file_save_in_locked); + if (keys %file_save_in > 1) { + push @errors, { + message => 'There are more than one file_save_in locations specified across columns. SlideShow expects them all to be the same', + }; + } + elsif (keys %file_save_in == 1) { + ($create_file_save_in) = keys %file_save_in; + $create_file_save_in_locked = $create_file_save_in; + } + + $create_file_save_in_locked or $create_file_save_in = $IN->param('create_file_save_in'); + + $tags->{create_file_save_in_locked} = $create_file_save_in_locked; + $tags->{create_file_save_in} = $create_file_save_in; + + # Add columns to the Links table if asked + my %fields_checked; + if (my @create_fields = $IN->param("create_field")) { + %fields_checked = map {($_=>1)} @create_fields; + + # Find out what types of fields we need to make. There are two types. + # File where the image file is loaded + # Description, a text field that contains a basic description of the image + my @ordered_create_fields = sort { + length($a) <=> length($b) || lc $a cmp lc $b + } @create_fields; + + my $led = $DB->editor('Links'); + + foreach my $field_name (@ordered_create_fields) { + if ($field_name =~ /_description/) { + $led->add_col( + $field_name => { + form_display => $field_name, + form_type => 'TEXTAREA', + form_size => '30', + type => 'TEXT', + } + ) or push @errors, { + message => q{Could not create field "$field_name" because "$GT::SQL::error"}, + }; + } + else { + unless ($create_file_save_in) { + push @errors, { + message => "You must provide a path to save the images being uploaded to create '$field_name'" + }; + next; + } + $led->add_col( + $field_name => { + form_display => $field_name, + form_type => 'FILE', + type => 'char', + size => 200, + file_save_in => $create_file_save_in, + file_save_scheme => 'HASHED', + file_max_size => '', + } + ) or push @errors, { + message => qq{Could not create field "$field_name" because "$GT::SQL::error"} + }; + } + } + } # endif (my @create_fields = $IN->param("create_field")) + + $tags->{fun_field_check} = sub { + my $field = shift; + return $fields_checked{$field} ? 'checked' : ''; + }; + + my (@missing_fields, @available_fields); + foreach my $col (@columns) { + if ($lcols->{$col}) { + my $desc_col = { field_name => $col, %{$lcols->{$col}} }; + $col =~ /description$/ and $desc_col->{file_save_in} = 'n/a'; + push @available_fields, $desc_col; + } + else { + push @missing_fields, $col; + } + } + + if (@missing_fields) { + $tags->{missing_field_list} = [ + map {{ field_name => $_ }} @missing_fields + ]; + } + + @errors and $tags->{errors} = \@errors; + @available_fields and $tags->{available_field_list} = \@available_fields; + + my $cols_template = << 'END_OF_TEMPLATE'; + + + + +Links SQL - Plugin Wizard + + + + +

        +
        + + + + + + + + +
        SlideShow Field Management
        +

        Field Manager

        +

        The SlideShow field manager allows you to rapidly create new image fields and inspect the existing image fields on your system. +

        + +
        +

        + +<%if errors%> +
        + + + + + + + +
        + Ooops, we had errors running the plugin action. +
          + <%loop errors%> +
        • <%message%>
        • + <%endloop%> +
        +
        + +
        +

        + +<%endif%> + +<%if available_field_list%> +

        +
        + + + + + + + + + <%loop available_field_list%> + + + + + + + + <%endloop%> + +
        + Field Name + + File Save Path +
        + <%field_name%> + + <%file_save_in%> +
        + +
        +

        +<%endif%> + +<%if missing_field_list%> + +
        + + + + + +

        +
        + + + + + + + +
        + Your database is currently missing fields that the + SlideShow plugin requires to function properly. +
        + +
        +

        + +

        +
        + + + + + + + + + <%loop missing_field_list%> + + + + + <%endloop%> + + + + + + + + + + + + + +
        + + + + Create? + Missing Column Name
        > + <%field_name%> +

        + <%if create_file_save_in_locked%> + <%html_escape create_file_save_in_locked%> + <%else%> + Please specify save directory: + <%endif%> +
        + +
        +

        + +
        + +<%endif%> + +END_OF_TEMPLATE + + print $IN->header; + require GT::Template; + print GT::Template->parse('slideshow_cols', $tags, { string => $cols_template }); + +} +END_OF_SUB + +sub resize_image; +$COMPILE{resize_image} = __LINE__ . <<'END_OF_SUB'; +sub resize_image { +# -------------------------------------------------- + my ($fpath, $fopath, $mx, $my, $quality) = @_; + + return unless -f $fpath; + return unless -s $fpath; + + my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow'); + + # We will switch between the binary convert or the perl module + # Image::Magick based upon the key "convert_fpath". We believe + # the convert binary to be better than the perl module as is: + # a.) faster, no perl api to deal with + # b.) if it crashes don't take down perl with it and we can + # recover from the error (the perl module seems to + # segfault perl sometimes causing 500s and no recourse) + # + ATTEMPT_RESIZING: { + ATTEMPT_BINARY_CONVERT: { + if (my $convert_fpath = $cfg->{convert_fpath}) { + + unless (-f $convert_fpath) { + warn "Cannot find '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + unless (-x $convert_fpath) { + warn "Cannot execute '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + my $err = system( + $convert_fpath, + ($quality?("-quality",$quality):()), + "-geometry", + "${mx}x${my}", + $fpath, + $fopath + ); + $err and warn "Could not convert using binary because: $?"; + last ATTEMPT_RESIZING; + } + }; + + # Well, we don't have the convert f-path setup properly + # so let's just load up the perl modules. + + # load up the image to resize + require Image::Magick; + my $image = Image::Magick->new(); + my $err = $image->Read(filename => $fpath); + + # deal with width + my ($iwidth, $iheight) = $image->Get('width', 'height'); + my $resize_percent = 1; + + if ($iwidth > $mx) { + $resize_percent = $mx / $iwidth; + } + + if ($iheight * $resize_percent > $my) { + $resize_percent = $my / $iheight; + } + + # Resize + my $nw = int($iwidth*$resize_percent); + my $nh = int($iheight*$resize_percent); + + $err = $image->Scale(width => $nw, height => $nh); + $quality and $image->Set(quality => $quality); + $image->Write($fopath); + + $image = undef; + } + + return $fopath; +} +END_OF_SUB + +sub crop_resize_image; +$COMPILE{crop_resize_image} = __LINE__ . <<'END_OF_SUB'; +sub crop_resize_image { +# -------------------------------------------------- + my ($fpath, $fopath, $mx, $my, $quality) = @_; + + return unless -f $fpath; + return unless -s $fpath; + my $cfg = Links::Plugins->get_plugin_user_cfg('SlideShow'); + + # We will switch between the binary convert or the perl module + # Image::Magick based upon the key "convert_fpath". We believe + # the convert binary to be better than the perl module as is: + # a.) faster, no perl api to deal with + # b.) if it crashes don't take down perl with it and we can + # recover from the error (the perl module seems to + # segfault perl sometimes causing 500s and no recourse) + # + ATTEMPT_RESIZING: { + ATTEMPT_BINARY_CONVERT: { + if (my $convert_fpath = $cfg->{convert_fpath}) { + + unless (-f $convert_fpath) { + warn "Cannot find '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + unless (-x $convert_fpath) { + warn "Cannot execute '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + # Find out the parameters of the image + my ($iwidth, $iheight) = imgsize($fpath); + my $crop_resize_percent = 1; + + if ($iwidth > $mx) { + $crop_resize_percent = $mx / $iwidth; + } + + if ($iheight * $crop_resize_percent < $my) { + $crop_resize_percent = $my / $iheight; + } + + # Resize and crop + my $nw = int($iwidth*$crop_resize_percent); + my $nh = int($iheight*$crop_resize_percent); + my $ox = int(($nw - $mx) / 2); + my $oy = int(($nh - $my) / 2); + + my $err = system( + $convert_fpath, + "-scale", + "${nw}x${nh}", + "-crop", + "${mx}x${my}+${ox}+${oy}", + $fpath, + $fopath + ); + $err and warn "Could not convert using binary because: $?"; + last ATTEMPT_RESIZING; + } + }; + + # Well, we don't have the convert f-path setup properly + # so let's just load up the perl modules. + + # load up the image to crop_resize + require Image::Magick; + my $image = Image::Magick->new(); + my $err = $image->Read(filename => $fpath); + + # deal with width + my ($iwidth, $iheight) = $image->Get('width', 'height'); + my $crop_resize_percent = 1; + + if ($iwidth > $mx) { + $crop_resize_percent = $mx / $iwidth; + } + + if ($iheight * $crop_resize_percent < $my) { + $crop_resize_percent = $my / $iheight; + } + + # Resize + my $nw = int($iwidth*$crop_resize_percent); + my $nh = int($iheight*$crop_resize_percent); + $err = $image->Scale(width => $nw, height => $nh); + + # And now we can crop + my $ox = int(($nw - $mx) / 2); + my $oy = int(($nh - $my) / 2); + + $err = $image->Crop("${mx}x${my}+$ox+$oy"); + $quality and $image->Set(quality => $quality); + $image->Write($fopath); + + $image = undef; + }; + + return $fopath; +} +END_OF_SUB + +sub apply_watermark; +$COMPILE{apply_watermark} = __LINE__ . <<'END_OF_SUB'; +sub apply_watermark { +# -------------------------------------------------- + my ( $fpath, $watermark_path, $quality ) = @_; + return unless $watermark_path and -f $watermark_path; + + ATTEMPT_WATERMARKING: { + ATTEMPT_BINARY_WATERMARKING: { + unless (-f $convert_fpath) { + warn "Cannot find '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + unless (-x $convert_fpath) { + warn "Cannot execute '$convert_fpath'\n"; + last ATTEMPT_BINARY_CONVERT; + } + + # Then let's composite the original image over the target + my $err = system( + $convert_fpath, + $fpath, + $watermark_path, + "-geometry", + "+10+10", + "-composite", + $fopath + ); + $err and warn "Could not convert using binary because: $?"; + last ATTEMPT_WATERMARKING; + }; + + # Seems like we couldn't get the binary version of the watermarking working + require Image::Magick; + + my $base = Image::Magick->new; + my $im = Image::Magick->new; + + my $err; + $err = $base->Read($fpath); + $err and warn $err and return; + $err = $im->Read($watermark_path); + $err and warn $err and return; + + my $mask = $im->clone; + $err = $base->Composite( + image => $im, + opacity => '50', + compose => 'Over', + mask => $mask, + x => 10, + y => 10, + ); + $err and warn $err and return; + + $quality and $im->Set(quality => $quality); + + $err = $base->Write($fpath); + $err and warn $err and return; + } + + $base = $mask = $im = undef; +} +END_OF_SUB + +sub imgsize { +# -------------------------------------------------- + my $full_path = shift; + + unless ($INC{"GT/Image/Size.pm"}) { + eval "require GT::Image::Size"; + if ($@) { + { + local $/; + my $buf = ; + eval $buf; + }; + $INC{"GT/Image/Size.pm"}++; + } + } + + return GT::Image::Size::imgsize($full_path); +} + +sub throw_error { +# -------------------------------------------------- + my $error = shift; + GT::Plugins->action( STOP ); + $DB->table('Links')->warn($error); + return; +} + +# Always end with a 1. +1; +__DATA__ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# GT::Image::Size +# Author: via CPAN (see POD) +# Revision: $Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $ +# Based off: Image::Size, 2.99 +# +# ================================================================== +# +# This module is used to determine the size of a file, and is based on +# Image::Size (available at CPAN) version 2.99. It's been hacked up +# a little to use GT::AutoLoader instead of AutoLoader. It also had to +# be changed to _not_ use File::Spec, since that wasn't standard in +# Perl 5.004_04. +# +# Image/Size.pm had the following header: +# +############################################################################### +# +# This file copyright (c) 2000 by Randy J. Ray, all rights reserved +# +# Copying and distribution are permitted under the terms of the Artistic +# License as distributed with Perl versions 5.005 and later. +# +############################################################################### +# +# Once upon a time, this code was lifted almost verbatim from wwwis by Alex +# Knowles, alex@ed.ac.uk. Since then, even I barely recognize it. It has +# contributions, fixes, additions and enhancements from all over the world. +# +# See the file README [of the Image-Size package on CPAN] for change history. +# +############################################################################### + +package GT::Image::Size; + +require 5.002; + +use strict; +use Cwd (); +use Symbol (); +use GT::AutoLoader; +require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $revision $VERSION $NO_CACHE + %PCD_MAP $PCD_SCALE $read_in $last_pos *imagemagick_size); + +@ISA = qw(Exporter); +@EXPORT = qw(imgsize); +@EXPORT_OK = qw(imgsize html_imgsize attr_imgsize $NO_CACHE $PCD_SCALE); +%EXPORT_TAGS = ('all' => [ @EXPORT_OK ]); + +$revision = q$Id: SlideShow.pm,v 1.33 2008/09/11 16:23:05 aaron Exp $; +$VERSION = '1.20080911'; + +# Check if we have Image::Magick available +BEGIN { + eval { + local $SIG{__DIE__}; # protect against user installed die handlers + require Image::Magick; + }; + if ($@) { + *imagemagick_size = + sub + { + (undef, undef, "Data stream is not a known image file format"); + }; + } else { + *imagemagick_size = + sub + { + my ($file_name) = @_; + my $img = Image::Magick->new(); + my $x = $img->Read($file_name); + # Image::Magick error handling is a bit weird, see + # + if("$x") { + return (undef, undef, "$x"); + } else { + return ($img->Get('width', 'height', 'format')); + } + }; + } +} + +# This allows people to specifically request that the cache not be used +$NO_CACHE = 0; + +# Package lexicals - invisible to outside world, used only in imgsize +# +# Cache of files seen, and mapping of patterns to the sizing routine +my %cache = (); +my %type_map = ( '^GIF8[7,9]a' => \&gifsize, + "^\xFF\xD8" => \&jpegsize, + "^\x89PNG\x0d\x0a\x1a\x0a" => \&pngsize, + "^P[1-7]" => \&ppmsize, # also XVpics + '\#define\s+\S+\s+\d+' => \&xbmsize, + '\/\* XPM \*\/' => \&xpmsize, + '^MM\x00\x2a' => \&tiffsize, + '^II\x2a\x00' => \&tiffsize, + '^BM' => \&bmpsize, + '^8BPS' => \&psdsize, + '^PCD_OPA' => \&pcdsize, + '^FWS' => \&swfsize, + "^\x8aMNG\x0d\x0a\x1a\x0a" => \&mngsize); +# Kodak photo-CDs are weird. Don't ask me why, you really don't want details. +%PCD_MAP = ( 'base/16' => [ 192, 128 ], + 'base/4' => [ 384, 256 ], + 'base' => [ 768, 512 ], + 'base4' => [ 1536, 1024 ], + 'base16' => [ 3072, 2048 ], + 'base64' => [ 6144, 4096 ] ); +# Default scale for PCD images +$PCD_SCALE = 'base'; + +# +# These are lexically-scoped anonymous subroutines for reading the three +# types of input streams. When the input to imgsize() is typed, then the +# lexical "read_in" is assigned one of these, thus allowing the individual +# routines to operate on these streams abstractly. +# + +my $read_io = sub { + my $handle = shift; + my ($length, $offset) = @_; + + if (defined($offset) && ($offset != $last_pos)) + { + $last_pos = $offset; + return '' if (! seek($handle, $offset, 0)); + } + + my ($data, $rtn) = ('', 0); + $rtn = read $handle, $data, $length; + $data = '' unless ($rtn); + $last_pos = tell $handle; + + $data; +}; + +my $read_buf = sub { + my $buf = shift; + my ($length, $offset) = @_; + + if (defined($offset) && ($offset != $last_pos)) + { + $last_pos = $offset; + return '' if ($last_pos > length($$buf)); + } + + my $data = substr($$buf, $last_pos, $length); + $last_pos += length($data); + + $data; +}; + +sub imgsize +{ + my $stream = shift; + + my ($handle, $header); + my ($x, $y, $id, $mtime, @list); + # These only used if $stream is an existant open FH + my ($save_pos, $need_restore) = (0, 0); + # This is for when $stream is a locally-opened file + my $need_close = 0; + # This will contain the file name, if we got one + my $file_name = undef; + + $header = ''; + + if (ref($stream) eq "SCALAR") + { + $handle = $stream; + $read_in = $read_buf; + $header = substr($$handle, 0, 256); + } + elsif (ref $stream) + { + # + # I no longer require $stream to be in the IO::* space. So I'm assuming + # you don't hose yourself by passing a ref that can't do fileops. If + # you do, you fix it. + # + $handle = $stream; + $read_in = $read_io; + $save_pos = tell $handle; + $need_restore = 1; + + # + # First alteration (didn't wait long, did I?) to the existant handle: + # + # assist dain-bramaged operating systems -- SWD + # SWD: I'm a bit uncomfortable with changing the mode on a file + # that something else "owns" ... the change is global, and there + # is no way to reverse it. + # But image files ought to be handled as binary anyway. + # + binmode($handle); + seek($handle, 0, 0); + read $handle, $header, 256; + seek($handle, 0, 0); + } + else + { + unless ($NO_CACHE) + { + $stream = Cwd::cwd() . '/' . $stream + unless $stream =~ m{^(?:[a-zA-Z]:)?[\\/]}; + $mtime = (stat $stream)[9]; + if (-e "$stream" and exists $cache{$stream}) + { + @list = split(/,/, $cache{$stream}, 4); + + # Don't return the cache if the file is newer. + return @list[1 .. 3] unless ($list[0] < $mtime); + # In fact, clear it + delete $cache{$stream}; + } + } + + #first try to open the stream + $handle = Symbol::gensym(); + open($handle, "< $stream") or + return (undef, undef, "Can't open image file $stream: $!"); + + $need_close = 1; + # assist dain-bramaged operating systems -- SWD + binmode($handle); + read $handle, $header, 256; + seek($handle, 0, 0); + $read_in = $read_io; + $file_name = $stream; + } + $last_pos = 0; + + # + # Oh pessimism... set the values of $x and $y to the error condition. If + # the grep() below matches the data to one of the known types, then the + # called subroutine will override these... + # + $id = "Data stream is not a known image file format"; + $x = undef; + $y = undef; + + grep($header =~ /$_/ && (($x, $y, $id) = &{$type_map{$_}}($handle)), + keys %type_map); + + # + # Added as an afterthought: I'm probably not the only one who uses the + # same shaded-sphere image for several items on a bulleted list: + # + $cache{$stream} = join(',', $mtime, $x, $y, $id) + unless ($NO_CACHE or (ref $stream) or (! defined $x)); + + # + # If we were passed an existant file handle, we need to restore the + # old filepos: + # + seek($handle, $save_pos, 0) if $need_restore; + # ...and if we opened the file ourselves, we need to close it + close($handle) if $need_close; + + # + # Image::Magick operates on file names. + # + if ($file_name && ! defined($x) && ! defined($y)) { + ($x, $y, $id) = imagemagick_size($file_name); + } + + + # results: + return (wantarray) ? ($x, $y, $id) : (); +} + +sub html_imgsize +{ + my @args = imgsize(@_); + + # Use lowercase and quotes so that it works with xhtml. + return ((defined $args[0]) ? + sprintf('width="%d" height="%d"', @args) : + undef); +} + +sub attr_imgsize +{ + my @args = imgsize(@_); + + return ((defined $args[0]) ? + (('-width', '-height', @args)[0, 2, 1, 3]) : + undef); +} + +# This used only in gifsize: +sub img_eof +{ + my $stream = shift; + + return ($last_pos >= length($$stream)) if (ref($stream) eq "SCALAR"); + + eof $stream; +} + +# +# Autoloaded subroutines below this point +# + +########################################################################### +# Subroutine gets the size of the specified GIF +########################################################################### +$COMPILE{gifsize} = __LINE__ . <<'END_OF_SUB'; +sub gifsize { + my $stream = shift; + + my ($cmapsize, $buf, $h, $w, $x, $y, $type); + + my $gif_blockskip = sub { + my ($skip, $type) = @_; + my ($lbuf); + + &$read_in($stream, $skip); # Skip header (if any) + while (1) + { + if (&img_eof($stream)) + { + return (undef, undef, + "Invalid/Corrupted GIF (at EOF in GIF $type)"); + } + $lbuf = &$read_in($stream, 1); # Block size + last if ord($lbuf) == 0; # Block terminator + &$read_in($stream, ord($lbuf)); # Skip data + } + }; + + $type = &$read_in($stream, 6); + if (length($buf = &$read_in($stream, 7)) != 7 ) + { + return (undef, undef, "Invalid/Corrupted GIF (bad header)"); + } + ($x) = unpack("x4 C", $buf); + if ($x & 0x80) + { + $cmapsize = 3 * (2**(($x & 0x07) + 1)); + if (! &$read_in($stream, $cmapsize)) + { + return (undef, undef, + "Invalid/Corrupted GIF (global color map too small?)"); + } + } + + FINDIMAGE: + while (1) + { + if (&img_eof($stream)) + { + return (undef, undef, + "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)"); + } + $buf = &$read_in($stream, 1); + ($x) = unpack("C", $buf); + if ($x == 0x2c) + { + # Image Descriptor (GIF87a, GIF89a 20.c.i) + if (length($buf = &$read_in($stream, 8)) != 8) + { + return (undef, undef, + "Invalid/Corrupted GIF (missing image header?)"); + } + ($x, $w, $y, $h) = unpack("x4 C4", $buf); + $x += $w * 256; + $y += $h * 256; + return ($x, $y, 'GIF'); + } + if ($x == 0x21) + { + # Extension Introducer (GIF89a 23.c.i, could also be in GIF87a) + $buf = &$read_in($stream, 1); + ($x) = unpack("C", $buf); + if ($x == 0xF9) + { + # Graphic Control Extension (GIF89a 23.c.ii) + &$read_in($stream, 6); # Skip it + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0xFE) + { + # Comment Extension (GIF89a 24.c.ii) + &$gif_blockskip(0, "Comment"); + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0x01) + { + # Plain Text Label (GIF89a 25.c.ii) + &$gif_blockskip(13, "text data"); + next FINDIMAGE; # Look again for Image Descriptor + } + elsif ($x == 0xFF) + { + # Application Extension Label (GIF89a 26.c.ii) + &$gif_blockskip(12, "application data"); + next FINDIMAGE; # Look again for Image Descriptor + } + else + { + return (undef, undef, + sprintf("Invalid/Corrupted GIF (Unknown " . + "extension %#x)", $x)); + } + } + else + { + return (undef, undef, + sprintf("Invalid/Corrupted GIF (Unknown code %#x)", + $x)); + } + } +} +END_OF_SUB + +$COMPILE{xbmsize} = __LINE__ . <<'END_OF_SUB'; +sub xbmsize { + my $stream = shift; + + my $input; + my ($x, $y, $id) = (undef, undef, "Could not determine XBM size"); + + $input = &$read_in($stream, 1024); + if ($input =~ /^\#define\s*\S*\s*(\d+)\s*\n\#define\s*\S*\s*(\d+)/si) + { + ($x, $y) = ($1, $2); + $id = 'XBM'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# Added by Randy J. Ray, 30 Jul 1996 +# Size an XPM file by looking for the "X Y N W" line, where X and Y are +# dimensions, N is the total number of colors defined, and W is the width of +# a color in the ASCII representation, in characters. We only care about X & Y. +$COMPILE{xpmsize} = __LINE__ . <<'END_OF_SUB'; +sub xpmsize { + my $stream = shift; + + my $line; + my ($x, $y, $id) = (undef, undef, "Could not determine XPM size"); + + while ($line = &$read_in($stream, 1024)) + { + next unless ($line =~ /"\s*(\d+)\s+(\d+)(\s+\d+\s+\d+){1,2}\s*"/s); + ($x, $y) = ($1, $2); + $id = 'XPM'; + last; + } + + ($x, $y, $id); +} +END_OF_SUB + + +# pngsize : gets the width & height (in pixels) of a png file +# cor this program is on the cutting edge of technology! (pity it's blunt!) +# +# Re-written and tested by tmetro@vl.com +$COMPILE{pngsize} = __LINE__ . <<'END_OF_SUB'; +sub pngsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "could not determine PNG size"); + my ($offset, $length); + + # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1 + $offset = 12; $length = 4; + if (&$read_in($stream, $length, $offset) eq 'IHDR') + { + # IHDR = Image Header + $length = 8; + ($x, $y) = unpack("NN", &$read_in($stream, $length)); + $id = 'PNG'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# mngsize: gets the width and height (in pixels) of an MNG file. +# See for the specification. +# +# Basically a copy of pngsize. +$COMPILE{mngsize} = __LINE__ . <<'END_OF_SUB'; +sub mngsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "could not determine MNG size"); + my ($offset, $length); + + # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1 + $offset = 12; $length = 4; + if (&$read_in($stream, $length, $offset) eq 'MHDR') + { + # MHDR = Image Header + $length = 8; + ($x, $y) = unpack("NN", &$read_in($stream, $length)); + $id = 'MNG'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# jpegsize: gets the width and height (in pixels) of a jpeg file +# Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995 +# modified slightly by alex@ed.ac.uk +# and further still by rjray@blackperl.com +# optimization and general re-write from tmetro@vl.com +$COMPILE{jpegsize} = __LINE__ . <<'END_OF_SUB'; +sub jpegsize { + my $stream = shift; + + my $MARKER = "\xFF"; # Section marker. + + my $SIZE_FIRST = 0xC0; # Range of segment identifier codes + my $SIZE_LAST = 0xC3; # that hold size info. + + my ($x, $y, $id) = (undef, undef, "could not determine JPEG size"); + + my ($marker, $code, $length); + my $segheader; + + # Dummy read to skip header ID + &$read_in($stream, 2); + while (1) + { + $length = 4; + $segheader = &$read_in($stream, $length); + + # Extract the segment header. + ($marker, $code, $length) = unpack("a a n", $segheader); + + # Verify that it's a valid segment. + if ($marker ne $MARKER) + { + # Was it there? + $id = "JPEG marker not found"; + last; + } + elsif ((ord($code) >= $SIZE_FIRST) && (ord($code) <= $SIZE_LAST)) + { + # Segments that contain size info + $length = 5; + ($y, $x) = unpack("xnn", &$read_in($stream, $length)); + $id = 'JPG'; + last; + } + else + { + # Dummy read to skip over data + &$read_in($stream, ($length - 2)); + } + } + + ($x, $y, $id); +} +END_OF_SUB + +# ppmsize: gets data on the PPM/PGM/PBM family. +# +# Contributed by Carsten Dominik +$COMPILE{ppmsize} = __LINE__ . <<'END_OF_SUB'; +sub ppmsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, + "Unable to determine size of PPM/PGM/PBM data"); + my $n; + + my $header = &$read_in($stream, 1024); + + # PPM file of some sort + $header =~ s/^\#.*//mg; + ($n, $x, $y) = ($header =~ /^(P[1-6])\s+(\d+)\s+(\d+)/s); + $id = "PBM" if $n eq "P1" || $n eq "P4"; + $id = "PGM" if $n eq "P2" || $n eq "P5"; + $id = "PPM" if $n eq "P3" || $n eq "P6"; + if ($n eq 'P7') + { + # John Bradley's XV thumbnail pics (thanks to inwap@jomis.Tymnet.COM) + $id = 'XV'; + ($x, $y) = ($header =~ /IMGINFO:(\d+)x(\d+)/s); + } + + ($x, $y, $id); +} +END_OF_SUB + +# tiffsize: size a TIFF image +# +# Contributed by Cloyce Spradling +$COMPILE{tiffsize} = __LINE__ . <<'END_OF_SUB'; +sub tiffsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of TIFF data"); + + my $endian = 'n'; # Default to big-endian; I like it better + my $header = &$read_in($stream, 4); + $endian = 'v' if ($header =~ /II\x2a\x00/o); # little-endian + + # Set up an association between data types and their corresponding + # pack/unpack specification. Don't take any special pains to deal with + # signed numbers; treat them as unsigned because none of the image + # dimensions should ever be negative. (I hope.) + my @packspec = ( undef, # nothing (shouldn't happen) + 'C', # BYTE (8-bit unsigned integer) + undef, # ASCII + $endian, # SHORT (16-bit unsigned integer) + uc($endian), # LONG (32-bit unsigned integer) + undef, # RATIONAL + 'c', # SBYTE (8-bit signed integer) + undef, # UNDEFINED + $endian, # SSHORT (16-bit unsigned integer) + uc($endian), # SLONG (32-bit unsigned integer) + ); + + my $offset = &$read_in($stream, 4, 4); # Get offset to IFD + $offset = unpack(uc($endian), $offset); # Fix it so we can use it + + my $ifd = &$read_in($stream, 2, $offset); # Get number of directory entries + my $num_dirent = unpack($endian, $ifd); # Make it useful + $offset += 2; + $num_dirent = $offset + ($num_dirent * 12); # Calc. maximum offset of IFD + + # Do all the work + $ifd = ''; + my $tag = 0; + my $type = 0; + while (!defined($x) || !defined($y)) { + $ifd = &$read_in($stream, 12, $offset); # Get first directory entry + last if (($ifd eq '') || ($offset > $num_dirent)); + $offset += 12; + $tag = unpack($endian, $ifd); # ...and decode its tag + $type = unpack($endian, substr($ifd, 2, 2)); # ...and the data type + # Check the type for sanity. + next if (($type > @packspec+0) || (!defined($packspec[$type]))); + if ($tag == 0x0100) { # ImageWidth (x) + # Decode the value + $x = unpack($packspec[$type], substr($ifd, 8, 4)); + } elsif ($tag == 0x0101) { # ImageLength (y) + # Decode the value + $y = unpack($packspec[$type], substr($ifd, 8, 4)); + } + } + + # Decide if we were successful or not + if (defined($x) && defined($y)) { + $id = 'TIF'; + } else { + $id = ''; + $id = 'ImageWidth ' if (!defined($x)); + if (!defined ($y)) { + $id .= 'and ' if ($id ne ''); + $id .= 'ImageLength '; + } + $id .= 'tag(s) could not be found'; + } + + ($x, $y, $id); +} +END_OF_SUB + +# bmpsize: size a Windows-ish BitMaP image +# +# Adapted from code contributed by Aldo Calpini +$COMPILE{bmpsize} = __LINE__ . <<'END_OF_SUB'; +sub bmpsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of BMP data"); + my ($buffer); + + $buffer = &$read_in($stream, 26); + ($x, $y) = unpack("x18VV", $buffer); + $id = 'BMP' if (defined $x and defined $y); + + ($x, $y, $id); +} +END_OF_SUB + +# psdsize: determine the size of a PhotoShop save-file (*.PSD) +$COMPILE{psdsize} = __LINE__ . <<'END_OF_SUB'; +sub psdsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of PSD data"); + my ($buffer); + + $buffer = &$read_in($stream, 26); + ($y, $x) = unpack("x14NN", $buffer); + $id = 'PSD' if (defined $x and defined $y); + + ($x, $y, $id); +} +END_OF_SUB + +# swfsize: determine size of ShockWave/Flash files. Adapted from code sent by +# Dmitry Dorofeev +$COMPILE{swfsize} = __LINE__ . <<'END_OF_SUB'; +sub swfsize { + my $image = shift; + my $header = &$read_in($image, 33); + + sub _bin2int { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } + + my $ver = _bin2int(unpack 'B8', substr($header, 3, 1)); + my $bs = unpack 'B133', substr($header, 8, 17); + my $bits = _bin2int(substr($bs, 0, 5)); + my $x = int(_bin2int(substr($bs, 5+$bits, $bits))/20); + my $y = int(_bin2int(substr($bs, 5+$bits*3, $bits))/20); + + return ($x, $y, 'SWF'); +} +END_OF_SUB + +# Suggested by Matt Mueller , and based on a piece of +# sample Perl code by a currently-unknown author. Credit will be placed here +# once the name is determined. +$COMPILE{pcdsize} = __LINE__ . <<'END_OF_SUB'; +sub pcdsize { + my $stream = shift; + + my ($x, $y, $id) = (undef, undef, "Unable to determine size of PCD data"); + my $buffer = &$read_in($stream, 0xf00); + + # Second-tier sanity check + return ($x, $y, $id) unless (substr($buffer, 0x800, 3) eq 'PCD'); + + my $orient = ord(substr($buffer, 0x0e02, 1)) & 1; # Clear down to one bit + ($x, $y) = @{$GT::Image::Size::PCD_MAP{lc $GT::Image::Size::PCD_SCALE}} + [($orient ? (0, 1) : (1, 0))]; + + return ($x, $y, 'PCD'); +} +END_OF_SUB + +1; + +__END__ + +=head1 NAME + +GT::Image::Size - read the dimensions of an image in several popular formats + +=head1 SYNOPSIS + + use GT::Image::Size; + # Get the size of globe.gif + ($globe_x, $globe_y) = imgsize("globe.gif"); + # Assume X=60 and Y=40 for remaining examples + + use GT::Image::Size 'html_imgsize'; + # Get the size as 'width="X" height="Y"' for HTML generation + $size = html_imgsize("globe.gif"); + # $size == 'width="60" height="40"' + + use GT::Image::Size 'attr_imgsize'; + # Get the size as a list passable to routines in CGI.pm + @attrs = attr_imgsize("globe.gif"); + # @attrs == ('-width', 60, '-height', 40) + + use GT::Image::Size; + # Get the size of an in-memory buffer + ($buf_x, $buf_y) = imgsize(\$buf); + # Assuming that $buf was the data, imgsize() needed a reference to a scalar + +=head1 DESCRIPTION + +The B library is based upon the C script written by +Alex Knowles I<(alex@ed.ac.uk)>, a tool to examine HTML and add 'width' and +'height' parameters to image tags. The sizes are cached internally based on +file name, so multiple calls on the same file name (such as images used +in bulleted lists, for example) do not result in repeated computations. + +B provides three interfaces for possible import: + +=over + +=item imgsize(I) + +Returns a three-item list of the X and Y dimensions (width and height, in +that order) and image type of I. Errors are noted by undefined +(B) values for the first two elements, and an error string in the third. +The third element can be (and usually is) ignored, but is useful when +sizing data whose type is unknown. + +=item html_imgsize(I) + +Returns the width and height (X and Y) of I pre-formatted as a single +string C<'width="X" height="Y"'> suitable for addition into generated HTML IMG +tags. If the underlying call to C fails, B is returned. The +format returned is dually suited to both HTML and XHTML. + +=item attr_imgsize(I) + +Returns the width and height of I as part of a 4-element list useful +for routines that use hash tables for the manipulation of named parameters, +such as the Tk or CGI libraries. A typical return value looks like +C<("-width", X, "-height", Y)>. If the underlying call to C fails, +B is returned. + +=back + +By default, only C is exported. Any one or combination of the three +may be explicitly imported, or all three may be with the tag B<:all>. + +=head2 Input Types + +The sort of data passed as I can be one of three forms: + +=over + +=item string + +If an ordinary scalar (string) is passed, it is assumed to be a file name +(either absolute or relative to the current working directory of the +process) and is searched for and opened (if found) as the source of data. +Possible error messages (see DIAGNOSTICS below) may include file-access +problems. + +=item scalar reference + +If the passed-in stream is a scalar reference, it is interpreted as pointing +to an in-memory buffer containing the image data. + + # Assume that &read_data gets data somewhere (WWW, etc.) + $img = &read_data; + ($x, $y, $id) = imgsize(\$img); + # $x and $y are dimensions, $id is the type of the image + +=item Open file handle + +The third option is to pass in an open filehandle (such as an object of +the C class, for example) that has already been associated with +the target image file. The file pointer will necessarily move, but will be +restored to its original position before subroutine end. + + # $fh was passed in, is IO::File reference: + ($x, $y, $id) = imgsize($fh); + # Same as calling with filename, but more abstract. + +=back + +=head2 Recognized Formats + +GT::Image::Size natively understands and sizes data in the following formats: + +=over 4 + +=item GIF + +=item JPG + +=item XBM + +=item XPM + +=item PPM family (PPM/PGM/PBM) + +=item XV thumbnails + +=item PNG + +=item MNG + +=item TIF + +=item BMP + +=item PSD (Adobe PhotoShop) + +=item SWF (ShockWave/Flash) + +=item PCD (Kodak PhotoCD, see notes below) + +=back + +Additionally, if the B module is present, the file types +supported by it are also supported by GT::Image::Size. See also L<"CAVEATS">. + +When using the C interface, there is a third, unused value returned +if the programmer wishes to save and examine it. This value is the identity of +the data type, expressed as a 2-3 letter abbreviation as listed above. This is +useful when operating on open file handles or in-memory data, where the type +is as unknown as the size. The two support routines ignore this third return +value, so those wishing to use it must use the base C routine. + +Note that when the B fallback is used (for all non-natively +supported files), the data type identity comes directly from the 'format' +parameter reported by B, so it may not meet the 2-3 letter +abbreviation format. For example, a WBMP file might be reported as +'Wireless Bitmap (level 0) image' in this case. + +=head2 Information Cacheing and C<$NO_CACHE> + +When a filename is passed to any of the sizing routines, the default behavior +of the library is to cache the resulting information. The modification-time of +the file is also recorded, to determine whether the cache should be purged and +updated. This was originally added due to the fact that a number of CGI +applications were using this library to generate attributes for pages that +often used the same graphical element many times over. + +However, the cacheing can lead to problems when the files are generated +dynamically, at a rate that exceeds the resolution of the modification-time +value on the filesystem. Thus, the optionally-importable control variable +C<$NO_CACHE> has been introduced. If this value is anything that evaluates to a +non-false value (be that the value 1, any non-null string, etc.) then the +cacheing is disabled until such time as the program re-enables it by setting +the value to false. + +The parameter C<$NO_CACHE> may be imported as with the B routine, and +is also imported when using the import tag B>. If the programmer +chooses not to import it, it is still accessible by the fully-qualified package +name, B<$GT::Image::Size::NO_CACHE>. + +=head2 Sizing PhotoCD Images + +With version 2.95, support for the Kodak PhotoCD image format is +included. However, these image files are not quite like the others. One file +is the source of the image in any of a range of pre-set resolutions (all with +the same aspect ratio). Supporting this here is tricky, since there is nothing +inherent in the file to limit it to a specific resolution. + +The library addresses this by using a scale mapping, and requiring the user +(you) to specify which scale is preferred for return. Like the C<$NO_CACHE> +setting described earlier, this is an importable scalar variable that may be +used within the application that uses B. This parameter is called +C<$PCD_SCALE>, and is imported by the same name. It, too, is also imported +when using the tag B> or may be referenced as +B<$GT::Image::Size::PCD_SCALE>. + +The parameter should be set to one of the following values: + + base/16 + base/4 + base + base4 + base16 + base64 + +Note that not all PhotoCD disks will have included the C +resolution. The actual resolutions are not listed here, as they are constant +and can be found in any documentation on the PCD format. The value of +C<$PCD_SCALE> is treated in a case-insensitive manner, so C is the same +as C or C. The default scale is set to C. + +Also note that the library makes no effort to read enough of the PCD file to +verify that the requested resolution is available. The point of this library +is to read as little as necessary so as to operate efficiently. Thus, the only +real difference to be found is in whether the orientation of the image is +portrait or landscape. That is in fact all that the library extracts from the +image file. + +=head1 DIAGNOSTICS + +The base routine, C, returns B as the first value in its list +when an error has occured. The third element contains a descriptive +error message. + +The other two routines simply return B in the case of error. + +=head1 MORE EXAMPLES + +The B interface is also well-suited to use with the Tk +extension: + + $image = $widget->Photo(-file => $img_path, attr_imgsize($img_path)); + +Since the C classes use dashed option names as C does, no +further translation is needed. + +This package is also well-suited for use within an Apache web server context. +File sizes are cached upon read (with a check against the modified time of +the file, in case of changes), a useful feature for a B environment +in which a child process endures beyond the lifetime of a single request. +Other aspects of the B environment cooperate nicely with this +module, such as the ability to use a sub-request to fetch the full pathname +for a file within the server space. This complements the HTML generation +capabilities of the B module, in which C wants a URL but +C needs a file path: + + # Assume $Q is an object of class CGI, $r is an Apache request object. + # $imgpath is a URL for something like "/img/redball.gif". + $r->print($Q->img({ -src => $imgpath, + attr_imgsize($r->lookup_uri($imgpath)->filename) })); + +The advantage here, besides not having to hard-code the server document root, +is that Apache passes the sub-request through the usual request lifecycle, +including any stages that would re-write the URL or otherwise modify it. + +=head1 CAVEATS + +Caching of size data can only be done on inputs that are file names. Open +file handles and scalar references cannot be reliably transformed into a +unique key for the table of cache data. Buffers could be cached using the +MD5 module, and perhaps in the future I will make that an option. I do not, +however, wish to lengthen the dependancy list by another item at this time. + +As B operates on file names, not handles, the use of it is +restricted to cases where the input to C is provided as file name. + +=head1 SEE ALSO + +C for a description of C +and how to obtain it, L. + +=head1 AUTHORS + +Perl module interface by Randy J. Ray I<(rjray@blackperl.com)>, original +image-sizing code by Alex Knowles I<(alex@ed.ac.uk)> and Andrew Tong +I<(werdna@ugcs.caltech.edu)>, used with their joint permission. + +Some bug fixes submitted by Bernd Leibing I<(bernd.leibing@rz.uni-ulm.de)>. +PPM/PGM/PBM sizing code contributed by Carsten Dominik +I<(dominik@strw.LeidenUniv.nl)>. Tom Metro I<(tmetro@vl.com)> re-wrote the JPG +and PNG code, and also provided a PNG image for the test suite. Dan Klein +I<(dvk@lonewolf.com)> contributed a re-write of the GIF code. Cloyce Spradling +I<(cloyce@headgear.org)> contributed TIFF sizing code and test images. Aldo +Calpini I<(a.calpini@romagiubileo.it)> suggested support of BMP images (which +I I should have already thought of :-) and provided code to work +with. A patch to allow html_imgsize to produce valid output for XHTML, as +well as some documentation fixes was provided by Charles Levert +I<(charles@comm.polymtl.ca)>. The ShockWave/Flash support was provided by +Dmitry Dorofeev I<(dima@yasp.com)>. Though I neglected to take note of who +supplied the PSD (PhotoShop) code, a bug was identified by Alex Weslowski +, who also provided a test image. PCD support +was adapted from a script made available by Phil Greenspun, as guided to my +attention by Matt Mueller I. A thorough read of the +documentation and source by Philip Newton I +found several typos and a small buglet. Ville Skyttä I<(ville.skytta@iki.fi)> +provided the MNG and the Image::Magick fallback code. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SocialMedia.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SocialMedia.pm new file mode 100644 index 0000000..bfe1ff3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/SocialMedia.pm @@ -0,0 +1,619 @@ +# ================================================================== +# Plugins::SocialMedia - Auto Generated Program Module +# +# Plugins::SocialMedia +# Author : Gossamer Threads Inc. +# Version : 1.0 +# Updated : Tue Oct 29 11:32:05 2013 +# +# ================================================================== +# + +package Plugins::SocialMedia; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; +use Links::Build; +use Links::SiteHTML; +use Net::Twitter; +use Links::Plugins; +use LWP::Simple; +use JSON; +use URI; +use utf8; +use vars qw/$USE_HTML $TIME_START $TOTAL_TIME @CARP_NOT $GRAND_TOTAL/; +#use Scalar::Util 'blessed'; +use GT::File::Tools qw/mkpath dirname/; +use Carp; + +@CARP_NOT = 'GT::Plugins'; + +# Inherit from base class for debug and error methods +@Plugins::SocialMedia::ISA = qw(GT::Base); + +# Your code begins here. + + +# PLUGIN HOOKS +# =================================================================== + +sub post_twitter { + my $link = shift; + $link = format_link($link); + $link || return; + +# When no authentication is required: + my $nt = Net::Twitter->new(legacy => 0); + + my $consumer_key = "u4xwsqHZBKrdWYPrKCm8Lw"; + my $consumer_secret = "vjDF6FjeoPJW0WVwgqMEJeuJzilgSIu5QbPGQnWrMI"; + my $token = "1921299666-fMicJMBunBjgBb4ieszHo6tYV0mQcbbaMZU5wSB"; + my $token_secret = "Ko9gPpBaLxqQj6u68EWdlgnPinGSseVzrzUvytWric"; + +#return { error => 'error posting...unknown' }; + my $tags = $IN->param('twitter_hash_tags'); + $tags =~ s/\s+//g; + my @tags = split(',',$tags); + my $newtags; + for (@tags) { + $newtags .= ' #' . $_; + } + my $post_title = $IN->param('twitter_status'); + + my $len = length $link->{detailed_url}; + $len = 140 - 5 - $len; + $post_title = substr($post_title,0,$len) . "..." if (length $post_title > $len); + $post_title .= " " . $link->{detailed_url}; + $post_title .= $newtags; + +# As of 13-Aug-2010, Twitter requires OAuth for authenticated requests + $nt = Net::Twitter->new( + traits => [qw/API::RESTv1_1/], + consumer_key => $consumer_key, + consumer_secret => $consumer_secret, + access_token => $token, + access_token_secret => $token_secret, + ); + + my $result; + my $res = eval { $result = $nt->update($post_title) }; + if ( my $err = $@ ) { + die $@ unless $err and $err->isa('Net::Twitter::Error'); + #warn "HTTP Response Code: ", $err->code, "\n", + #"HTTP Message......: ", $err->message, "\n", + #"Twitter error.....: ", $err->error, "\n"; + $result->{error} = $err->error; + } + + return $result; +} + +sub post_facebook { +# ------------------------------------------------------------------- + my $access_token = shift; + my $id = shift; + my $link = format_link($id); + + if ($link->{facebook_hashtags}) { + $link->{Description} .= " "; + $link->{Description} .= $link->{facebook_hashtags}; + } + +#Publish to a facebook page as admin + my $cfg = Links::Plugins::get_plugin_user_cfg('Auth_Facebook'); + my $result = facebook_graph_api('/' . $cfg->{fb_fanpageid} . '/links',{ + link => "http://www.slowtwitch.com/temp/$id.html", + #link => $link->{detailed_url}, + message => $link->{Description}, + picture => $link->{Picture}, + access_token => $access_token, + method => 'post' + }); + + return $result; +} + +sub facebook_graph_api { +# ------------------------------------------------------------------- + my $uri = new URI('https://graph.facebook.com/' . shift); + $uri->query_form(shift); + + require GT::WWW; + my $www = GT::WWW->get("$uri"); + my $resp = $www->content; + return defined $resp ? decode_json($resp) : undef; +} + +sub format_link { +# ------------------------------------------------------------------- + my $link = shift; + if ($link =~ /^(\d+)$/) { + $link = $DB->table('Links')->get($link); + } + $link or return; + $link = Links::SiteHTML::tags('link',$link); + + my $len = length $link->{detailed_url}; + $len = 140 - 5 - $len; + $link->{Description} = substr($link->{Description},0,$len) . "..." if (length $link->{Description} > $len); + + my @cats = $DB->table('Category', 'CatLinks')->select('Category.Full_Name', { 'CatLinks.LinkID' => $link->{ID} })->fetchall_list; + $link->{Category} = join "\n", sort @cats; + + use Plugins::SlideShow; + my $paths = Plugins::SlideShow::generate_paths($link->{ID}); + $link->{image_paths} = $paths; + my $img = $link->{facebook_published_image} || "Image1"; + $link->{Picture} = $paths->{$img . '_largest_path'} if ($paths->{$img . '_largest_path'}); + + return $link; +} + +sub publish_it { +# ------------------------------------------------------------------- + if ($IN->param('build')) { + my $linkid = $IN->param('linkid'); + my ($twitter, $fb); + use Time::HiRes; + #Time::HiRes::sleep(5); #.1 seconds + #print $IN->header; + $IN->param('t','dev'); #FIXME + #print $IN->header; + build_it($linkid); + my $hash = {}; + + #print Links::user_page('add_success_publish.html', { success => '1', built => 1, twitter => $twitter, %$hash }); + #return; + + if ($IN->param('post_facebook')) { + if ($IN->param('post_twitter')) { + my $res = post_twitter($linkid); + if ($res->{id}) { + $DB->table('Links')->update({ twitter_published => $res->{id} }, { ID => $linkid }); + $hash->{twitter_published} = 1; + } + else { + $DB->table('Links')->update({ twitter_published_message => $res->{error} }, { ID => $linkid }); + $hash->{twitter_published_message} = $res->{error} if ($res->{error}); + } + } + use Plugins::Auth_Facebook; + Plugins::Auth_Facebook::user_auth($linkid); + return; + } + elsif ($IN->param('post_twitter')) { + my $res = post_twitter($linkid); + if ($res->{id}) { + $DB->table('Links')->update({ twitter_published => $res->{id} }, { ID => $linkid }); + $hash->{twitter_published} = 1; + } + else { + $DB->table('Links')->update({ twitter_published_message => $res->{error} }, { ID => $linkid }); + $hash->{twitter_published_message} = $res->{error} if ($res->{error}); + } + } + $IN->param('t','dev'); #FIXME + print $IN->header; + print Links::user_page('add_success_publish.html', { success => '1', built => 1, twitter => $twitter, %$hash }); + } + else { + print $IN->header; + print Links::user_page('error.html', { error => 'no error' }); + } +} + +sub build_it { +# ------------------------------------------------------------------- +# + my $linkid = shift || return; + my $unix_time = $CFG->{last_build} ? $CFG->{last_build} : time; + Links::init_date(); + my $time = GT::Date::date_get($unix_time - $CFG->{date_offset} * 3600, '%yyyy%-%mm%-%dd% %HH%:%MM%:%ss%'); + +=tag +# Do any backups. + _build_backup(); + +# Update isNew, isCool, isPopular flags. + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + +# Build Home Page. + $PLG->dispatch('create_home', \&_build_home, {}); +=cut + +=tag +# Build New Page. + $PLG->dispatch('create_new', \&_build_new, {}); + +# Build Cool Page. + $PLG->dispatch('create_cool', \&_build_cool, {}); + +# Build Ratings Page. + $PLG->dispatch('create_ratings', \&_build_ratings, {}); +=cut + +# Build Changed Detailed Page. + $PLG->dispatch('create_detailed_changed', \&_build_detailed, GT::SQL::Condition->new('Links.ID', '=', $linkid)); + +=tag +# Build Changed Category Pages. + $PLG->dispatch('create_category_changed', \&_build_category, GT::SQL::Condition->new('Timestmp', '>', $time)); + + $CFG->{last_build} = time; + $CFG->save; +=cut + +} + +sub get_path { +# ------------------------------------------------------------------- +# + my $field = shift; + my $filefield = $field . "_largest_path"; + my $link = GT::Template->tags(); + if (!$link->{$filefield}) { + $filefield = $field . "_medium_path"; + } + return $link->{$filefield}; +} + +# ------------------------------------------------------------------ +# MISC BUILD functions +# ------------------------------------------------------------------ +sub _build_home { +# ------------------------------------------------------------------ +# Generate the home page. +# + _time_start(); + + my $index = $CFG->{build_home} || $CFG->{build_index}; + my $page = "$CFG->{build_root_path}/$index"; + print $USE_HTML + ? qq'Building Home Page...\n' + : qq'Building Home Page...\n'; + + my $fh = _open_write($page); + print $fh Links::Build::build(home => {}); + close $fh; + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + _display_time(); +} + +sub _build_detailed { +# ------------------------------------------------------------------ +# Generate one html page per link. +# + require Links::Tools; + + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{limit}; + } + else { + $cond = shift; + } + unless ($CFG->{build_detailed}) { + print "Skipping Detailed Build (disabled).\n\n"; + return; + } + + _time_start(); + + #print "Building Detailed pages...\n"; + +# Only build validated links + $cond ||= GT::SQL::Condition->new; + $cond->add(VIEWABLE); + +# Loop through, building 1000 at a time + my ($limit, $offset, $count, $second_pass) = (1000, 0, 0); + my $rel = $DB->table(qw/Links CatLinks Category/); + #print "\t"; + + my $Links = $DB->table('Links'); + while () { +# Links can be in multiple categories, make sure their detailed pages are only built once + $rel->select_options("GROUP BY LinkID") if $CFG->{build_detail_format} eq '%ID%'; + $rel->select_options("ORDER BY LinkID"); + + if ($cust_page or $cust_limit) { + last if $second_pass++; + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1) * $cust_limit); + } + else { + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $limit, $offset*$limit); + } + my %links_cols = %{$Links->cols}; + # Only select Category columns that don't conflict with Links columns. + my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols}; + + my $sth = $rel->select('Links.*', @cat_cols, 'CategoryID' => $cond); + + last unless $sth->rows; + + while (my $link = $sth->fetchrow_hashref) { + my $format = $Links->detailed_url($link); + $format = "temp/" . $link->{ID} . ".html"; #FIXME + my $page = "$CFG->{build_detail_path}/$format"; + my $url = "$CFG->{build_detail_url}/$format"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(detailed => $link); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +=tag + $USE_HTML ? + print qq'$link->{ID} ' : + print "$link->{ID} "; + print "\n\t" if ++$count % 20 == 0; +=cut + } + $offset++; + } +=tag + print "\n"; + _display_time(); +=cut +} + +sub _build_category { +# ------------------------------------------------------------------ +# Generate the category pages. +# + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{offset}; + $cond = {}; + } + else { + $cond = shift; + } + + _time_start(); + + print "Building Category pages...\n\n"; + + my $Cat = $DB->table('Category'); + my $CatLinks = $DB->table('Links', 'CatLinks'); + + $Cat->select_options('ORDER BY Full_Name'); + if (defined $cust_page and $cust_limit) { + $Cat->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1)*$cust_limit); + } + my $sth = $Cat->select(ID => Full_Name => $cond); + while (my ($id, $name) = $sth->fetchrow_array) { + my $clean_name = $Cat->as_url($name); + my $page = $CFG->{build_root_path} . "/" . $clean_name . '/' . $CFG->{build_index}; + my $url = $CFG->{build_root_url} . "/" . $clean_name . '/' . $CFG->{build_index}; + print $USE_HTML + ? "\tBuilding category $name...\n" + : "\tBuilding category $name...\n"; + my $total = $CatLinks->count({ 'CatLinks.CategoryID' => $id }, VIEWABLE); + print "\t\tLinks: $total\n"; + +# Do sub-pages if requested. + if ($CFG->{build_span_pages}) { + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($total / $lpp); + $num_pages++ if $total % $lpp; + +# Create the main page. + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => 1, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Create the sub pages. + for (2 .. $num_pages) { + $page = "$CFG->{build_root_path}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + $url = "$CFG->{build_root_url}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + print "\t\tBuilding subpage: " . ($USE_HTML + ? "$_\n" + : "$_\n" + ); + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => $_, mh => $lpp }); + } + chmod $perms, $page; + } + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + print "\tDone\n\n"; + } + _display_time("Finished building categories"); +} + +sub _build_backup { +# ------------------------------------------------------------------ +# Create a backup file in our backup directory. +# + if (! $CFG->{build_use_backup}) { + print "Creating backup file... skipped\n\n"; + return; + } + _time_start(); + print "Creating backup file...\n"; + require Links::Import::S2BK; + + my $max_keep = 7; + my $root = $CFG->{admin_root_path} . '/backup'; + my $filename = 'BACKUP'; + + for my $n (reverse 0 .. $max_keep) { + my $oldname = join '.', $filename, $n || (); + my $newname = join '.', $filename, $n+1; + if (-e "$root/$oldname") { + rename "$root/$oldname", "$root/$newname" or print "\tCouldn't rename '$root/$oldname' -> '$root/$newname': $!"; + } + } + Links::Import::S2BK::import({ source => "$CFG->{admin_root_path}/defs", destination => "$root/$filename", delimiter => "\t" }, sub { print "\n\tWARNING: @_\n" }, sub { die @_ }, sub { print "\n\tWARNING: @_\n" }, sub { }); + _display_time(); +} + +sub _build_reset_hits { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Resetting hits and rates...\n"; + my $ret = Links::Build::build(reset_hits => shift || {}); + _display_time(); + return $ret; +} + +sub _build_new_flags { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Updating new flags...\n"; + my $ret = Links::Build::build(new_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_changed_flags { +# ------------------------------------------------------------------ +# Updates the isChanged flags. +# + _time_start(); + print "Updating changed flags...\n"; + my $ret = Links::Build::build(changed_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_cool_flags { +# ------------------------------------------------------------------ +# Updates the What's Cool flags. +# + _time_start(); + print "Updating Cool Flags...\n"; + my $ret = Links::Build::build(cool_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _time_start { +# ------------------------------------------------------------------ +# Start a timer. +# + $TIME_START = time; +} + +sub _display_time { +# ------------------------------------------------------------------ +# Return time results. +# + my $message = shift || 'Done'; + return; + printf "%s (%.2fs)\n\n", $message, time - $TIME_START; +} + +sub _header { +# ------------------------------------------------------------------ +# Print intro. +# + my ($msg, $msg2, $refresh, $started) = @_; + my $time = scalar localtime; + + $refresh ||= ''; + $TOTAL_TIME = $started || time; + $refresh &&= ""; + if ($USE_HTML) { + print $IN->header(-nph => $CFG->{nph_headers}); + print < + +$refresh +Building HTML Pages + +BUILDING + print Links::header("Building HTML Pages: $msg", $msg2, 0); + print <Started at $time. + +STARTED + } + else { + print "Started at $time.\n\nBuilding HTML pages...\n\n"; + } +} + +sub _footer { +# ------------------------------------------------------------------ +# Print the footer. +# + my $end = time; + my $elapsed = sprintf "%.2f", $end - $TOTAL_TIME; + + print "All done. Total time: (${elapsed}s)\n"; + print "
      • " if $USE_HTML; +} + +sub _open_write { +# ----------------------------------------------------------------------------- +# Opens a file for writing (overwriting anything already there), and returns a +# filehandle reference. Dies with a more user-friendly error then Links::fatal +# if the open fails. Can take a second argument which, if true, will cause the +# function _not_ to attempt to make the containing directory. +# + my ($page, $nomkdir) = @_; + unless ($nomkdir) { + mkpath(dirname($page), oct $CFG->{build_dir_per}); + } + my $fh = \do { local *FH; *FH }; + open $fh, "> $page" and return $fh; + + my $error = "$!"; + my $user = eval { getpwuid($>) } || 'webserver'; + if ($error =~ /permission/i) { + print "\n\nERROR: Unable to open '$page': $error\n\n"; + if (-e $page) { + print < 'video', + PHOTO => 'photo', + ARTICLE => 'article' +; +# Inherit from base class for debug and error methods +@Plugins::UI::ISA = qw(GT::Base); + +require Plugins::SlideShow; +require Plugins::ConvertVideo; +require GT::SQL::Condition; +require GT::Date; + +sub cat_url { + my $full_name = shift || return; + + return "$CFG->{build_root_url}/" . $DB->table('Category')->as_url($full_name) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); +} + +sub update_featured_links { + my ($type, $id, $add) = @_; + + return if $USER->{Status} ne 'Administrator'; + + return unless $id and $type; + return if $type !~ /^(article|photo|video)$/i; + + my $name = $type eq 'article' ? 'featured_articles' : 'featured_photos'; + my $ids = $CFG->{$name} || []; + + my (@ids, $changed); + my %ids = map { $_ => 1 } @$ids; + if ($add) { + if ($ids{$id}) { + @ids = @$ids; + } + else { + @ids = ($id, @$ids); + + my $hits = scalar @ids; + if ($type eq 'article' and $hits > 4) { + pop @ids; + } + elsif ($type ne 'article' and $hits > 2) { + pop @ids; + } + $changed = 1; + } + } + elsif ($ids{$id}) { + @ids = map $_, grep { $_ != $id } @$ids; + $changed = 1; + } + + return unless $changed; + + $CFG->{$name} = \@ids; + $CFG->save; + return; +} + +sub is_featured { + my ($type, $id) = @_; + + return unless $id and $type; + return if $type !~ /^(article|photo|video)$/i; + + my $name = $type eq 'article' ? 'featured_articles' : 'featured_photos'; + my $ids = $CFG->{$name} || []; + my %ids = map { $_ => 1 } @$ids; + return $ids{$id} ? 1 : 0; +} + +sub fetch_categories { + my $ids = shift; + + $ids = ref $ids ? @$ids : [$ids] if $ids; + + my $tab = $DB->table('Category'); + $tab->select_options('ORDER BY Name'); + my $cond = GT::SQL::Condition->new( CatDepth => '=' => 0); + $cond->add(ID => '=' => $ids) if $ids; + + my $cats = $tab->select($cond)->fetchall_hashref; + foreach (@$cats) { + $_->{URL} = "$CFG->{build_root_url}/" . $tab->as_url($_->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + } + return $cats; +} + +sub fetch_links { + my %args = @_; + + return unless %args; + + my $maxhits = $args{max_hits} || 1; + my $cond = new GT::SQL::Condition; + my $url = $CFG->{build_detail_url}; + my (@ids, %paging); + + my $tab_cat = $DB->table('Category'); + my $tab_lnks = $DB->table('Links'); + my $tab_catlnks = $DB->table(qw/Links CatLinks Category/); + if ($args{type}) { + $cond->add(Type => '=' => $args{type}); + $tab_catlnks->select_options("GROUP BY LinkID", "ORDER BY Add_Date DESC", "LIMIT $maxhits"); + } + elsif ($args{ids}) { + if (ref $args{ids} eq 'ARRAY') { + @ids = @{$args{ids}}; + } + else { + @ids = split(/\,|\r?\n/, $args{ids}); + } + return unless scalar @ids; + + $cond->add(LinkID => '=' => \@ids); + $tab_catlnks->select_options("ORDER BY Add_Date DESC"); + $tab_catlnks->select_options("LIMIT $maxhits") if $args{max_hits}; + } + elsif ($args{category}) { + my $category = $tab_cat->get($args{category}); + return unless $category; + + $cond->add(Full_Name => 'like' => $category->{Full_Name} . '%'); + $tab_catlnks->select_options("ORDER BY Add_Date DESC", "LIMIT $maxhits"); + } + elsif ($args{tag} and $args{tag} =~ /^(?:swim|bike|run)$/i) { + my $vars = GT::Template->vars; + my $tag = lc $args{tag}; + $url .= "/$tag"; + + $paging{max_hits} = $args{max_hits} || 25; + $paging{current_page} = $vars->{nh} || 1; + $paging{page} = $args{url} || ($tag . '/'); + + my $offset = $paging{current_page} == 1 ? 0 : ($paging{current_page} - 1) * $paging{max_hits}; + + $cond->add('tag_' . $tag => '=' => 1); + $tab_catlnks->select_options("GROUP BY LinkID", "ORDER BY Add_Date DESC", "LIMIT $paging{max_hits} OFFSET $offset"); + } + elsif ($args{link_type} and $args{link_type} =~ /^(?:photo|video)$/i) { + my $vars = GT::Template->vars; + $url .= "/" . ($args{link_type} eq 'video' ? 'Videos' : 'Photos'); + + $paging{max_hits} = $args{max_hits} || 25; + $paging{current_page} = $vars->{nh} || 1; + $paging{page} = ($args{link_type} eq 'video' ? 'Videos' : 'Photos') . '/'; + + my $offset = $paging{current_page} == 1 ? 0 : ($paging{current_page} - 1) * $paging{max_hits}; + + $cond->add(Link_Type => '=' => $args{link_type}); + $tab_catlnks->select_options("GROUP BY LinkID", "ORDER BY Add_Date DESC", "LIMIT $paging{max_hits} OFFSET $offset"); + } + else { + $tab_catlnks->select_options("GROUP BY LinkID", "ORDER BY Add_Date DESC", "LIMIT $maxhits"); + } + + my $links = ($tab_catlnks->select(qw/Links.* Name Full_Name/, $cond) or die $GT::SQL::error)->fetchall_hashref; + return unless scalar @$links; + + foreach my $l (@$links) { + $l->{detailed_url} = "$url/" . $tab_lnks->detailed_url($l->{ID}) if $CFG->{build_detailed}; + $l->{URL} = "$CFG->{build_root_url}/" . $tab_cat->as_url($l->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + $l->{thumbnail_url} = fetch_thumbnail($l); + } + + if (scalar @ids and !$args{db}) { + my @links_output; + my %links = map { $_->{ID} => $_ } @$links; + + foreach my $id (@ids) { + push @links_output, $links{$id} if $links{$id}; + } + + return \@links_output; + } + elsif ( + ($args{link_type} and $args{link_type} =~ /^(?:photo|video)$/) or + ($args{tag} and $args{tag} =~ /^(?:swim|bike|run)$/) + ) { + $paging{num_hits} = $tab_lnks->select('COUNT(*)', $cond)->fetchrow; + + my @features; + if ($paging{current_page} == 1) { + @features = splice @$links, 0, 3; + } + return { loop => $links, features => \@features, paging => \%paging }; + } + else { + return $links; + } +} + +sub fetch_category { + my $catid = shift || return; + return $DB->table('Category')->get($catid); +} + +sub fetch_widget { + my $id = shift || return; + + my $tab = $DB->table('Widgets'); + my $widget = $tab->get($id); + + return unless $widget; + + if ($widget->{Image}) { + my $fh = $tab->file_info('Image', $widget->{ID}); + $widget->{Image_URL} = '/images/widgets/' . $fh->File_RelativeURL; + } + return $widget; +} + +sub fetch_widgets { + my ($page, $catid) = @_; + + return unless $page; + + my $tab_pgwidgets = $DB->table(qw/Widgets PageWidgets/); + $tab_pgwidgets->select_options('ORDER BY Sort_Pos'); + + my $widgets = []; + if ($catid =~ /^\d+$/) { + $widgets = $tab_pgwidgets->select(qw/Widgets.* Sort_Pos/, { Page => $catid })->fetchall_hashref; + } + + unless (scalar @$widgets) { + $widgets = $tab_pgwidgets->select(qw/Widgets.* Sort_Pos/, { Page => $page })->fetchall_hashref; + } + my $tab = $DB->table('Widgets'); + foreach my $w (@$widgets) { + next unless $w->{Image}; + my $fh = $tab->file_info('Image', $w->{ID}); + next unless $fh; + $w->{Image_URL} = '/images/widgets/' . $fh->File_RelativeURL; + } + return $widgets; +} + +sub generate_widget { + my $id = shift || return; + + my $widget = fetch_widget($id); + + return unless $widget; + return Links::SiteHTML::display('include_single_widget', $widget); +} + +sub friendly_date { + my ($date, $timestmp, $format) = @_; + + return unless $date; + + my $days = GT::Date::date_diff(GT::Date::date_get(time, '%yyyy%-%mm%-%dd%'), $date); + unless ($days) { + my $time = GT::Date::timelocal(GT::Date::parse_format($timestmp, "%yyyy%-%mm%-%dd% %HH%:%MM%:%ss%")); + my $secs = time - $time; + return unless $secs; + + $date = $timestmp; + return "$secs seconds ago" if $secs < 60; + + my $mins = int($secs / 60); + return "$mins minutes ago" if $mins < 60; + + my $hours = int($secs / 3600); + return $hours . ($hours > 1 ? " hours ago" : " hour ago"); + } + else { + my $time = GT::Date::timelocal(GT::Date::parse_format($date, "%yyyy%-%mm%-%dd%")); + $date = $time; + + return ($format or $days > 7) + ? GT::Date::date_get($date, $format || "%mmm% %dd%, %yyyy%") + : $days . ($days > 1 ? " days ago" : " day ago"); + } +} + +sub retrieve_param { + my ($field, $count) = @_; + + return unless $field; + + $count ||= 1; + my $vars = GT::Template->vars; + + if ($field eq 'Image_description') { + return $vars->{"Image${count}_description"}; + } + elsif ($field =~ /^Image_(.*)$/) { + return $vars->{"Image${count}_$1"} || $vars->{"Image${count}_path"}; + } + else { + return $vars->{"$field$count"}; + } +} + +sub fetch_thumbnail { + my $link = shift || return; + + if ($link->{Link_Type} eq VIDEO) { + if ($link->{Thumbnail_URL} and $link->{Thumbnail_URL} ne 'http://') { + return { small => $link->{Thumbnail_URL} }; + } + else { + my $field = Plugins::ConvertVideo::get_file_path($link->{ID}, "thumbnail_file_field"); + return $field->{thumbnail_file_field_path} + ? { + small => $field->{thumbnail_file_field_path}, + medium => $field->{thumbnail_file_field_path}, + large => $field->{thumbnail_file_field_path}, + largest => $field->{thumbnail_file_field_path}, + } + : undef; + } + } + else { + my $slideshow = Plugins::SlideShow::generate_paths($link->{ID}); + if ($slideshow and $slideshow->{image_loop}) { + return { + small => $slideshow->{image_loop}->[0]{_thumbnail_path}, + medium => $slideshow->{image_loop}->[0]{_medium_path}, + large => $slideshow->{image_loop}->[0]{_large_path}, + largest => $slideshow->{image_loop}->[0]{_largest_path} + }; + } + } +} + +sub slideshow_url { + my $url = shift || return; + + $url =~ s,^$CFG->{build_detail_url},$CFG->{build_detail_url}/Photos,; + return $url; +} + +sub rewrite_breadcrumbs { + my ($title_loop, $mode) = @_; + + return unless ref $title_loop; + + my @loop; + foreach my $i (0 .. scalar @$title_loop - 1) { + my $item = $title_loop->[$i]; + if ($i == 1) { + if ($item->{Name} =~ /rd\s*aids/i) { + push @loop, { + Name => "Races", + URL => "$CFG->{build_root_url}/Races/index.html" + }; + } + elsif ($mode) { + push @loop, { + Name => $mode eq 'photo' ? 'Photo Galleries' : 'Videos', + URL => "$CFG->{build_root_url}/" . ($mode eq 'photo' ? 'Photos' : 'Videos') . "/index.html" + }; + } + elsif ($item->{Name} !~ /home|bike\s*fit|products|races|articles|photos|videos|coaching|podcast|privacy|about|agreement/i) { + push @loop, { + Name => "Articles", + URL => "$CFG->{build_root_url}/Articles/index.html" + }; + } + } + push @loop, $item; + } + return \@loop; +} + +sub build_category { + my $opts = shift; + $opts->{id} ||= $IN->param('ID'); + + return @_ unless $opts->{id}; + + my $cfg = Links::Plugins->get_plugin_user_cfg('UI'); + return @_ unless $cfg and $cfg->{merge_categories}; + + my %ids = map { $_ => 1 } split(/\s*,\s*/, $cfg->{merge_categories}); + return @_ unless $ids{$opts->{id}}; + + GT::Plugins->action( STOP ); + + my $cat_db = $DB->table('Category'); + my $link_db = $DB->table('Links'); + my $catlink_db = $DB->table('Links', 'CatLinks'); + my $related_db = $DB->table('CatRelations'); + $Links::Build::GRAND_TOTAL ||= Links::Build::_grand_total(); + + if (ref $opts ne 'HASH') { + Links::debug("Invalid argument passed to build_category: $opts") if $Links::DEBUG; + return @_; + } + +# Load our category info. + my $category; + if ($opts->{id}) { + $category = $cat_db->get($opts->{id}, 'HASH'); + if (! $category) { + Links::debug("Invalid category id passed to build_category: $opts->{id}") if $Links::DEBUG; + return; + } + } + +# Get our options. + $opts->{mh} = exists $opts->{mh} ? $opts->{mh} : $CFG->{build_span_pages} ? $CFG->{build_links_per_page} : 5000; + $opts->{nh} = exists $opts->{nh} ? $opts->{nh} : 1; + $opts->{sb} = exists $opts->{sb} ? $opts->{sb} : $CFG->{build_sort_order_category}; + $opts->{so} = exists $opts->{so} ? $opts->{so} : ''; + if ($opts->{sb} =~ /\b(?:asc|desc)\b/i) { + $opts->{so} = ''; + } + $opts->{cat_sb} = exists $opts->{cat_sb} ? $opts->{cat_sb} : $CFG->{build_category_sort}; + $opts->{cat_so} = exists $opts->{cat_so} ? $opts->{cat_so} : ''; + if ($opts->{cat_sb} =~ /\b(?:asc|desc)\b/i) { + $opts->{cat_so} = ''; + } + +# Figure out the template set to use. + $category->{Category_Template} ||= $cat_db->template_set($category->{ID}); + +# Get our output vars. + my %tplvars = ( + %$category, + category_id => $category->{ID}, + category_name => $category->{Full_Name}, + header => $category->{Header}, + footer => $category->{Footer}, + meta_name => $category->{Meta_Description}, + meta_keywords => $category->{Meta_Keywords}, + description => $category->{Description}, + random => int rand 10000, + random1 => int rand 10000, + random2 => int rand 10000, + random3 => int rand 10000 + ); + +# Clean up the name. + my $clean_name = $cat_db->as_url($category->{Full_Name}); + my $build_title = $category->{Full_Name}; + $build_title .= '/' . Links::language('LINKS_PAGE', $opts->{nh}) if $opts->{nh} and $opts->{nh} > 1; + + $tplvars{title_loop} = Links::Build::build('title', $build_title); + $tplvars{title_linked} = sub { Links::Build::build('title_linked', $build_title) }; + $tplvars{title} = sub { Links::Build::build('title_unlinked', $build_title) }; + + $tplvars{category_name_escaped} = GT::CGI->escape($category->{Full_Name}); + $tplvars{category_clean} = $tplvars{title}; + ($tplvars{category_short}) = $tplvars{category_name} =~ m|([^/]+)$|; + + # CUSTOMIZED: show all links in a category as well as subcategories + my $categories = $cat_db->children($category->{ID}); + push @$categories, $category->{ID}; + + my $cond = GT::SQL::Condition->new( + CategoryID => '=' => $categories, + isValidated => '=' => 'Yes' + ); + +# "Optional" payment categories are a hassle, as we have to do two selects, +# then balance out the mh/nh variables between the two. + my ($optional_sth, $sth); + my @select_options; + push @select_options, "ORDER BY $opts->{sb} $opts->{so}" if $opts->{sb}; + +# Load payment info if payment is enabled. Change sort order by paid links +# first then free links if payment for this category is optional. If payment +# is required, we need to remove unpaid links + if ($CFG->{payment}->{enabled}) { + require Links::Payment; + my $payment_info = Links::Payment::cat_payment_info($opts->{id}); + + if ($payment_info->{mode} == OPTIONAL and $CFG->{build_sort_paid_first}) { + my $paycond = GT::SQL::Condition->new($cond); + $paycond->add(ExpiryDate => '>=' => time, ExpiryDate => '<=' => UNLIMITED); + + my $offset = ($opts->{nh} - 1) * $opts->{mh}; + $catlink_db->select_options(@select_options); + $catlink_db->select_options("LIMIT $opts->{mh} OFFSET $offset"); + $optional_sth = $catlink_db->select('Links.*', $paycond); + + $cond->add(ExpiryDate => '=' => FREE); + } + else { + # 1) This is an else (instead of elsif ($payment_info->{mode} == REQUIRED)) because the + # run-time count updating code cannot efficiently take category settings into account + # as doing so requires either subselects (which older MySQL doesn't support), or a fair + # bit of Perl code; a single fast count to determine whether the check is necessary + # won't work. The end result is that counts would be off. + # 2) Even if this was an elsif, we can't include ExpiryDate <= UNLIMITED (to exclude + # free links) because links being free is the default for imported, upgraded, and + # admin-added links, which we don't want to exclude from REQUIRED categories. + $cond->add(ExpiryDate => '>=' => time); + } + } + + my @results; + my ($paid_hits, $paid_rows, $offset, $max_hits) = (0, 0, ($opts->{nh} - 1) * $opts->{mh}, $opts->{mh}); + if ($optional_sth) { + push @results, @{$optional_sth->fetchall_hashref}; + $paid_rows = $optional_sth->rows; + $paid_hits = $catlink_db->hits; + if ($paid_rows == $opts->{mh}) { + $offset = $max_hits = 0; + } + elsif ($paid_rows > 0) { + $offset = 0; + $max_hits = $opts->{mh} - $paid_rows; + } + else { + $offset -= $paid_hits; + } + } + my $hits; +# Select links from required categories, not-accepted categories, and optional +# categories whose paid hits haven't filled the page + if ($max_hits) { # $max_hits will be 0 when mh paid links are already listed + $catlink_db->select_options(@select_options); + $catlink_db->select_options("LIMIT $max_hits OFFSET $offset"); + my @ids = map $_->[0], @{$catlink_db->select('DISTINCT LinkID', $cond)->fetchall_arrayref}; + + $link_db->select_options(@select_options); + my $sth = $link_db->select({ ID => \@ids }); + + push @results, @{$sth->fetchall_hashref}; + $hits = $catlink_db->hits; + } + else { + $hits = $catlink_db->count($cond); + } + + my $numlinks = $tplvars{total} = $hits + $paid_hits; + $tplvars{total_optional_paid} = $paid_hits; + +# Get the links. + $link_db->add_reviews(\@results); + my @links_loop = map Links::SiteHTML::tags('link', $_, undef) => @results; + $tplvars{links_loop} = \@links_loop; + $tplvars{links_count} = @links_loop; + my $links; + $tplvars{links} = sub { + return $links if defined $links; + $links = ''; + for my $link (@results) { + $link->{Category_Template} = $category->{Category_Template} if $category->{Category_Template}; + $links .= Links::SiteHTML::display('link', $link); + } + return $links; + }; +# Get the subcategories and related categories as either Yahoo style (integrated) or +# separated into two outputs.. + my @cat_loop; + $tplvars{category_loop} = \@cat_loop; + if ($CFG->{build_category_yahoo}) { + my @subcat_ids = $cat_db->select(ID => { FatherID => $category->{ID} })->fetchall_list; + my %related_ids = $related_db->select(qw/RelatedID RelationName/ => { CategoryID => $category->{ID} })->fetchall_list; + if (@subcat_ids or keys %related_ids) { + $cat_db->select_options("ORDER BY $opts->{cat_sb} $opts->{cat_so}") if $opts->{cat_sb}; + my $sth = $cat_db->select({ ID => [@subcat_ids, keys %related_ids] }); + my @rel_loop; + while (my $cat = $sth->fetchrow_hashref) { + $cat->{URL} = "$CFG->{build_root_url}/" . $cat_db->as_url($cat->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + $cat->{RelationName} = ''; + if (exists $related_ids{$cat->{ID}}) { + $cat->{Related} = 1; + $cat->{RelationName} = $related_ids{$cat->{ID}}; +# Relations with a custom name need to be re-sorted + if ($cat->{RelationName}) { + push @rel_loop, $cat; + next; + } + } + push @cat_loop, $cat; + } +# Re-sort related categories using their RelationName rather than the related +# category's name + RELATION: while (my $cat = pop @rel_loop) { + for (my $i = 0; $i < @cat_loop; $i++) { + my $name = $cat_loop[$i]->{RelationName} ? $cat_loop[$i]->{RelationName} : $cat_loop[$i]->{Name}; + if (lc $cat->{RelationName} lt lc $name) { + splice @cat_loop, $i, 0, $cat; + next RELATION; + } + } + push @cat_loop, $cat; + } + my $print_cat; + $tplvars{category} = sub { + return $print_cat if defined $print_cat; + return $print_cat = Links::SiteHTML::display('print_cat', [$category, @cat_loop]); + }; + } + else { + $tplvars{category} = ''; + } + } + else { +# Separate the output. + $cat_db->select_options("ORDER BY $opts->{cat_sb} $opts->{cat_so}") if $opts->{cat_sb}; + $sth = $cat_db->select({ FatherID => $category->{ID} }); + while (my $cat = $sth->fetchrow_hashref) { + $cat->{URL} = "$CFG->{build_root_url}/" . $cat_db->as_url($cat->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + push @cat_loop, $cat; + } + if (@cat_loop) { + my $print_cat; + $tplvars{category} = sub { + return $print_cat if defined $print_cat; + return $print_cat = Links::SiteHTML::display('print_cat', [$category, @cat_loop]); + }; + } + else { + $tplvars{category} = ''; + } + $tplvars{related} = ''; + $tplvars{related_loop} = []; + + my %related_ids = $related_db->select(qw/RelatedID RelationName/ => { CategoryID => $category->{ID} })->fetchall_list; + if (keys %related_ids) { + $cat_db->select_options("ORDER BY $opts->{cat_sb} $opts->{cat_so}") if $opts->{cat_sb}; + my $sth = $cat_db->select({ ID => [keys %related_ids] }); + while (my $cat = $sth->fetchrow_hashref) { + my $url = $CFG->{build_root_url} . "/" . $cat_db->as_url($cat->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + $cat->{URL} = $url; + $cat->{RelationName} = $related_ids{$cat->{ID}}; + push @{$tplvars{related_loop}}, $cat; + $tplvars{related} .= qq|
      • | . ($related_ids{$cat->{ID}} || $cat->{Full_Name}) . "
      • "; + } + } + } + + # Plugins can use the build_category_loop hook to change the category + # results before they are returned to the template. + $PLG->dispatch(build_category_loop => sub { } => \@cat_loop); + +# Get the header and footer from file if it exists, otherwise assume it is html. + if ($tplvars{header} and $tplvars{header} =~ /^\S{1,20}$/ and -e "$CFG->{admin_root_path}/headers/$tplvars{header}") { + local (@ARGV, $/) = "$CFG->{admin_root_path}/headers/$tplvars{header}"; + $tplvars{header} = <>; + } + if ($tplvars{footer} and $tplvars{footer} =~ /^\S{1,20}$/ and -e "$CFG->{admin_root_path}/footers/$tplvars{footer}") { + local (@ARGV, $/) = "$CFG->{admin_root_path}/footers/$tplvars{footer}"; + $tplvars{footer} = <>; + } + +# If we are spanning pages, figure out toolbars and such. + if ($CFG->{build_span_pages}) { + my $lpp = $CFG->{build_links_per_page}; + my $nh = $opts->{nh}; + my $url = $CFG->{build_root_url} . "/" . $clean_name; + $tplvars{next} = $tplvars{prev} = ""; + if ($numlinks > ($nh * $lpp)) { + $tplvars{next} = "$url/$CFG->{build_more}" . ($nh + 1) . "$CFG->{build_extension}"; + } + if ($nh == 2) { + $tplvars{prev} = "$url/" . ($CFG->{build_index_include} ? $CFG->{build_index} : ''); + } + elsif ($nh > 2) { + $tplvars{prev} = "$url/$CFG->{build_more}" . ($nh - 1) . "$CFG->{build_extension}"; + } + if ($tplvars{next} or $tplvars{prev}) { + $tplvars{next_span} = Links::Build::build('toolbar', { url => $url, numlinks => $numlinks, nh => $nh }); + $tplvars{paging} = { + page => "$clean_name/", + page_format => 1, + num_hits => $numlinks, + max_hits => $opts->{mh}, + current_page => $opts->{nh} + }; + } + } + + return Links::SiteHTML::display('category', \%tplvars); +} + +sub fetch_widget_external_links { + my $id = shift || return; + + return $DB->table('WidgetLinks')->select({ WidgetID => $id })->fetchall_hashref; +} +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Widgets.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Widgets.pm new file mode 100644 index 0000000..1364a45 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/Widgets.pm @@ -0,0 +1,322 @@ +# ================================================================== +# Plugins::Widgets - Auto Generated Program Module +# +# Plugins::Widgets +# Author : Bao Phan +# Version : 1.0 +# Updated : Mon Mar 21 11:08:31 2016 +# +# ================================================================== +# + +package Plugins::Widgets; +# ================================================================== + +use strict; +use GT::Base; +use GT::Plugins qw/STOP CONTINUE/; +use Links qw/:objects/; + +# Inherit from base class for debug and error methods +@Plugins::Widgets::ISA = qw(GT::Base); + +# Your code begins here. + + +# ADMIN MENU OPTIONS +# =================================================================== + +sub widgets { +# ------------------------------------------------------------------- +# This subroutine will be called whenever the user clicks on 'Widgets' in the +# admin menu. Remember, you need to print your own HTTP header; to do so you +# can use: + my $args = shift || {}; + + print $IN->header; + Links::admin_page('widgets.html', { widgets => fetch_widgets($IN->param('page')), %$args }); +} + +sub assign { + my $cgi = $IN->get_hash(); + + my $msg; + if ($cgi->{page} and $cgi->{id} and $cgi->{pos}) { + my $widget = $DB->table('Widgets')->get($cgi->{id}); + my $page = $cgi->{page}; + + my $tab_pgwidgets = $DB->table('PageWidgets'); + my $pg_widget = $tab_pgwidgets->select({ WidgetID => $widget->{ID}, Page => $page })->fetchrow_hashref; + + my ($msg, $category); + + $category = $DB->table('Category')->get($page) if $page =~ /^\d+$/; + if (!$pg_widget and $cgi->{pos} =~ /^\d+$/) { + $tab_pgwidgets->insert({ WidgetID => $widget->{ID}, Page => $page, Sort_Pos => $cgi->{pos} || 0 }) or die $GT::SQL::error; + $msg = "The widget was added to page: " . ($category ? $category->{Full_Name} : $page); + } + elsif ($cgi->{pos} =~ /^\d+$/) { + $tab_pgwidgets->update({ Sort_Pos => $cgi->{pos} }, { ID => $pg_widget->{ID} }); + $msg = "The widget's position was updated on page: " . ($category ? $category->{Full_Name} : $page); + } + else { + $tab_pgwidgets->delete({ ID => $pg_widget->{ID} }); + $msg = "The widget was removed from: " . ($category ? $category->{Full_Name} : $page); + } + } + return widgets({ msg => $msg }); +} + +sub add { + my $cgi = $IN->get_hash(); + + my $error; + if ($cgi->{submit}) { + # automated widget + my @fields = ('ID', 'Type', 'Widget', 'Title', 'Subtitle', 'TitleStyle', 'Image', 'URL', 'Button'); + if ($cgi->{Type}) { + return form('Widget and Title cannot be null') unless $cgi->{Widget} and $cgi->{Title}; + + if ($cgi->{Widget} eq 'category_list') { + return form('Select a category') unless $cgi->{Category}; + + push @fields, 'Category'; + } + elsif ($cgi->{Widget} eq 'poll') { + return form('Select a forum') unless $cgi->{Forum}; + + push @fields, 'Forum'; + } + elsif ($cgi->{Widget} =~ /^(:?feature_article|editors_pick|feature_threads)$/) { + return form('Enter Article IDs, comma separated') unless $cgi->{Articles}; + push @fields, 'Articles'; + } + elsif ($cgi->{Widget} eq 'newsletter') { + return form('Enter List ID') unless $cgi->{ListID}; + push @fields, 'ListID'; + } + elsif ($cgi->{Widget} eq 'external') { + return form('Enter widget title') unless $cgi->{Title}; + } + } + + + my $rec; + if ($cgi->{Widget} eq 'external') { + $rec = $DB->table('Widgets')->add({ + Title => $cgi->{Title}, + TitleStyle => $cgi->{TitleStyle}, + Widget => 'external', + Type => 1 + }); + return form($GT::SQL::error) unless $rec; + + my $num_links = $cgi->{NumLinks} || 5; + my $tab_links = $DB->table("WidgetLinks"); + for my $i (1 .. $num_links) { + next unless $cgi->{"Title-$i"} and $cgi->{"Abstract-$i"} and $cgi->{"URL-$i"} and $cgi->{"URL-$i"} =~ /^http/; + $tab_links->insert({ + WidgetID => $rec, + Title => $cgi->{"Title-$i"}, + Abstract => $cgi->{"Abstract-$i"}, + URL => $cgi->{"URL-$i"}, + }); + } + } + else { + my %hash = map { $_ => $cgi->{$_} } @fields; + $rec = $DB->table('Widgets')->add(\%hash); + return form($GT::SQL::error) unless $rec; + } + + + if ($cgi->{page}) { + my $tab_pgwidgets = $DB->table('PageWidgets'); + my $max_pos = $tab_pgwidgets->select('MAX(Sort_Pos)', { Page => $cgi->{page} })->fetchrow || 0; + $tab_pgwidgets->insert({ WidgetID => $rec, Page => $cgi->{page}, Sort_Pos => $max_pos + 1 }); + } + return widgets({ success => "The widget was added" }); + } + + form(); +} + +sub modify { + my $cgi = $IN->get_hash(); + my $widget = $DB->table('Widgets')->get($cgi->{ID}); + return form("Widget not found") unless $widget; + + if ($cgi->{submit}) { + # automated widget + my @fields = ('ID', 'Type', 'Widget', 'Title', 'Subtitle', 'TitleStyle', 'Image', 'URL', 'Button'); + if ($cgi->{Type}) { + return form('Widget and Title cannot be null') unless $cgi->{Widget} and $cgi->{Title}; + + if ($cgi->{Widget} eq 'category_list') { + return form('Select a category') unless $cgi->{Category}; + push @fields, 'Category'; + } + elsif ($cgi->{Widget} eq 'poll') { + return form('Select a forum') unless $cgi->{Forum}; + push @fields, 'Forum'; + } + elsif ($cgi->{Widget} =~ /^(:?feature_article|editors_pick|feature_threads)$/) { + return form('Enter Article IDs, comma separated') unless $cgi->{Articles}; + push @fields, 'Articles'; + } + elsif ($cgi->{Widget} eq 'newsletter') { + return form('Enter List ID') unless $cgi->{ListID}; + push @fields, 'ListID'; + } + elsif ($cgi->{Widget} eq 'external') { + return form('Enter widget title') unless $cgi->{Title}; + } + } + + my %hash = map { $_ => $cgi->{$_} } @fields; + if ($cgi->{Widget} eq 'external') { + $DB->table('Widgets')->update({ + Title => $cgi->{Title}, + TitleStyle => $cgi->{TitleStyle}, + }, { ID => $cgi->{ID} }); + + my $num_links = $cgi->{NumLinks} || 5; + my $tab_links = $DB->table("WidgetLinks"); + for my $i (1 .. $num_links) { + my $id = $cgi->{"ID-$i"}; + + unless ($cgi->{"Title-$i"} and $cgi->{"URL-$i"} and $cgi->{"URL-$i"} =~ /^http/) { + $tab_links->delete({ ID => $id }) if $id; + } + elsif ($id) { + $tab_links->update({ + Title => $cgi->{"Title-$i"}, + Abstract => $cgi->{"Abstract-$i"}, + URL => $cgi->{"URL-$i"}, + }, { ID => $id }); + } + else { + $tab_links->insert({ + WidgetID => $cgi->{ID}, + Title => $cgi->{"Title-$i"}, + Abstract => $cgi->{"Abstract-$i"}, + URL => $cgi->{"URL-$i"}, + }); + } + } + } + else { + my $rec = $DB->table('Widgets')->modify(\%hash); + } + return widgets({ success => "The widget was updated" }); + } + else { + $IN->param($_, $widget->{$_}) for keys %$widget; + if ($widget->{Widget} eq 'external') { + my $links = $DB->table('WidgetLinks')->select({ WidgetID => $widget->{ID} })->fetchall_hashref; + my $i = 1; + foreach my $l (@$links) { + $IN->param("$_-$i", $l->{$_}) foreach (qw/ID Title Abstract URL/); + $i++; + } + } + return form(); + } +} + +sub retrieve_ntag { + my ($name, $index) = @_; + return unless $name and $index; + my $vars = GT::Template->vars; + + return $vars->{"$name-$index"}; +} + +sub delete { + my $tab = $DB->table('Widgets'); + my $widget = $tab->get($IN->param('ID')); + return widgets({ error => "Widget not found" }) unless $widget; + + $tab->delete({ ID => $widget->{ID} }); + $DB->table('PageWidgets')->delete({ WidgetID => $widget->{ID} }); + $DB->table('WidgetLinks')->delete({ WidgetID => $widget->{ID} }); + widgets({ success => "The widget was deleted" }); +} + +sub form { + print $IN->header; + my $widget = $IN->param('Widget') || ''; + + Links::admin_page($widget eq 'external' ? 'widgetlink_add.html' : 'widget_add.html', { error => shift }); +} + +sub fetch_widgets { + my $page = shift; + + my $tab = $DB->table('Widgets'); + my $tab_pgwidgets = $DB->table('PageWidgets'); + my $tab_category = $DB->table('Category'); + + $tab->select_options('ORDER BY Title'); + my $widgets = $tab->select()->fetchall_hashref; + + my (%selected, %widgets); + if ($page) { + %selected = map { $_->{WidgetID} => $_->{Sort_Pos} } @{$tab_pgwidgets->select({ Page => $page })->fetchall_hashref}; + } + + my (@selected, @noselected); + foreach my $w (@$widgets) { + if ($w->{Image}) { + my $fh = $tab->file_info('Image', $w->{ID}); + $w->{Image_URL} = '/images/widgets/' . $fh->File_RelativeURL; + } + + $w->{pages} = $tab_pgwidgets->select({ WidgetID => $w->{ID} })->fetchall_hashref; + if ($selected{$w->{ID}}) { + $w->{selected} = $selected{$w->{ID}}; + push @selected, $w; + } + else { + push @noselected, $w; + } + } + + @selected = @{qsort(\@selected, 'selected', 'asc')} if scalar @selected; + return { selected => \@selected, available => \@noselected }; +} + +sub fetch_categories { + my $tab = $DB->table('Category'); + + $tab->select_options('ORDER BY Full_Name'); + my $categories = $tab->select()->fetchall_hashref; + return $categories; +} + +sub qsort { + my ($list, $sb, $so) = @_; + my $sorted; + @$sorted = + sort { + my $da = lc $a->{$sb}; #lower case + my $db = lc $b->{$sb}; + my $res; + if ($sb eq 'selected') { + $res = $db <=> $da; + } + else { + $res = $db cmp $da; + } + if ($res == 0 and $sb ne 'name') { + lc $b->{name} cmp lc $a->{name}; + } + else { + $res; + } + } @$list; + + ($so) and @$sorted = reverse @$sorted; + return $sorted; +} +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/plugin.cfg b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/plugin.cfg new file mode 100644 index 0000000..8b690a5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Plugins/plugin.cfg @@ -0,0 +1,470 @@ +{ + 'Auth_Facebook' => { + 'hooks' => [], + 'meta' => { + 'author' => 'Virginia Lo', + 'description' => '', + 'license' => 'Other', + 'prog_ver' => '3.2.0', + 'url' => 'http://www.gossamer-threads.com', + 'version' => '1.0' + }, + 'user' => [ + [ + 'fb_postback_url', + 'https://www.slowtwitch.com/facebook/', + 'Facebook postback url', + 'TEXT', + [], + [], + '' + ], + [ + 'fb_fanpageid', + '395855247207719', + '', + 'TEXT', + [], + [] + ], + [ + 'fb_appid', + '535394536545179', + '', + 'TEXT', + [], + [] + ], + [ + 'fb_secret_key', + '0468d894e46463929bacfb6c484be3ea', + '', + 'TEXT', + [], + [] + ] + ], + 'version' => '1.0' + }, + 'ConvertVideo' => { + 'hooks' => [ + [ + 'validate_link', + 'PRE', + 'Plugins::ConvertVideo::validate_link_pre', + '1' + ], + [ + 'modify_link', + 'PRE', + 'Plugins::ConvertVideo::modify_link_pre', + '1' + ], + [ + 'modify_link', + 'POST', + 'Plugins::ConvertVideo::modify_link_post', + '1' + ], + [ + 'add_link', + 'POST', + 'Plugins::ConvertVideo::add_link_post', + '1' + ], + [ + 'form_link', + 'PRE', + 'Plugins::ConvertVideo::pre_form_link', + '1' + ], + [ + 'form_link', + 'POST', + 'Plugins::ConvertVideo::post_form_link', + '1' + ] + ], + 'meta' => { + 'author' => 'Gossamer Threads Inc.', + 'description' => 'Convert mpeg video to flash file.', + 'license' => 'Other', + 'prog_ver' => '3.x', + 'url' => 'http://www.gossamer-threads.com', + 'version' => '1.1' + }, + 'user' => [ + [ + 'video_file_field', + 'File_Path', + 'Field name of the video file field.', + 'TEXT', + [], + [], + '' + ], + [ + 'flash_file_field', + 'Flash_Path', + 'Field name of the flash file field.', + 'TEXT', + [], + [], + '' + ], + [ + 'image_file_field', + 'Image_Path', + 'Field name of the preview image file field.', + 'TEXT', + [], + [], + '' + ], + [ + 'thumbnail_file_field', + 'Thumbnail_Path', + 'Field name of the thumbnail file field.', + 'TEXT', + [], + [], + '' + ], + [ + 'video_url_field', + 'URL', + 'Field name of the video url field.', + 'TEXT', + [], + [], + '' + ], + [ + 'flash_dimension', + '630x398', + 'The size of the flash movie (e.g. 450x370)', + 'TEXT', + [], + [], + '' + ], + [ + 'flash_quality', + '1', + 'quality scale (1 [best] - 31 [worst])', + 'TEXT', + [], + [], + '' + ], + [ + 'thumbnail_size', + '108x108', + 'The size of the thumbnail.', + 'TEXT', + [], + [], + '' + ], + [ + 'watermark_file', + '', + 'The path to the watermark image.', + 'TEXT', + [], + [], + '' + ], + [ + 'video_url', + '/videos', + 'The url where you store the video files.', + 'TEXT', + [], + [], + '' + ], + [ + 'flowplayer_url', + '/videos/static', + 'The url path where you store the flowplayer swf and javascript files.', + 'TEXT', + [], + [], + '' + ] + ], + 'version' => '1.1' + }, + 'HandlePage' => { + 'hooks' => [ + [ + 'handle_page', + 'PRE', + 'Plugins::HandlePage::pre_handle_page', + '1' + ] + ], + 'meta' => { + 'author' => 'Gossamer Threads Inc. (Virginia Lo)', + 'description' => '', + 'license' => 'Other', + 'prog_ver' => '3.3.0', + 'url' => 'http://www.gossamer-threads.com', + 'version' => '1.0' + }, + 'version' => '1.0' + }, + 'MostPopular' => { + 'hooks' => [ + [ + 'jump_link', + 'PRE', + 'Plugins::MostPopular::jump_link', + '1' + ] + ], + 'meta' => { + 'author' => 'Virginia Lo', + 'description' => '', + 'license' => 'Other', + 'prog_ver' => '3.2.0', + 'url' => 'http://www.gossamer-threads.com', + 'version' => '1.0' + }, + 'user' => [ + [ + 'last_x_days', + '14', + 'most popular articles over the course of the last x days. ', + 'TEXT', + [], + [], + '' + ] + ], + 'version' => '1.0' + }, + 'OverrideModDate' => { + 'hooks' => [ + [ + 'handle_modify', + 'PRE', + 'Plugins::OverrideModDate::pre_handle', + '1' + ], + [ + 'user_add_link', + 'POST', + 'Plugins::OverrideModDate::post_add_link', + '1' + ], + [ + 'modify_link', + 'POST', + 'Plugins::OverrideModDate::post_modify_link', + '1' + ] + ], + 'meta' => { + 'author' => 'Gossamer Threads Inc.', + 'description' => 'Don\'t auto set the Add_Date and Mod_Date if a user wants to modify it. ', + 'license' => 'Other', + 'prog_ver' => '3.2.0', + 'url' => 'http://www.gossamer-threads.com', + 'version' => '1.0' + }, + 'version' => '1.0' + }, + 'SlideShow' => { + 'hooks' => [ + [ + 'add_link', + 'PRE', + 'Plugins::SlideShow::add_link', + '1' + ], + [ + 'modify_link', + 'PRE', + 'Plugins::SlideShow::modify_link', + '1' + ], + [ + 'user_modify_link', + 'PRE', + 'Plugins::SlideShow::check_input', + '1' + ] + ], + 'menu' => [ + [ + 'Help', + 'admin.cgi?do=help&topic=SlideShow/help.html" target="_blank', + '1' + ], + [ + 'Field Management', + 'admin.cgi?do=plugin&plugin=SlideShow&func=field_management', + '1' + ], + [ + 'Edit', + 'admin.cgi?do=page&page=plugin_manager.html&plugin_man_do=edit_installed&plugin_name=SlideShow', + '1' + ], + [ + 'Resize', + 'nph-imageresize.cgi', + '1' + ] + ], + 'meta' => { + 'author' => 'Gossamer Threads Inc.', + 'description' => 'This uses the SlideShow libraries and packages to allow you to run a photo gallery. This plugin automatically creates thumbnails of uploaded pictures and allows you to view them in a special frame.', + 'license' => 'Commercial', + 'prog_ver' => '2.1.1', + 'url' => 'http://www.gossamer-threads.com/', + 'version' => '1.20070309' + }, + 'user' => [ + [ + 'max_upload_constraints', + '2000x2000', + 'Maximum size allowed for the uploaded image.' + ], + [ + 'max_upload_size', + '1000000', + 'Maximum size in bytes for the uploaded image.' + ], + [ + 'link_type_1', + 'article', + 'Link type for image width and height constraint.' + ], + [ + 'thumbnail_constraints_1', + '100x100', + 'Maximum width and height for thumbnail for link_type_1.' + ], + [ + 'medium_constraints_1', + '300x300', + 'Maximum width and height for medium sized image for link_type_1.' + ], + [ + 'large_constraints_1', + 'crop470x260', + 'Maximum width and height for large image for link_type_1.' + ], + [ + 'largest_constraints_1', + '620x620', + 'Maximum width and height for largest image for link_type_1.' + ], + [ + 'link_type_2', + 'photo', + 'Link type for image width and height constraint.' + ], + [ + 'thumbnail_constraints_2', + 'crop107x80', + 'Maximum width and height for thumbnail for link_type_2.' + ], + [ + 'medium_constraints_2', + 'crop300x166', + 'Maximum width and height for medium sized image for link_type_2.' + ], + [ + 'large_constraints_2', + 'crop470x260', + 'Maximum width and height for large image for link_type_2.' + ], + [ + 'largest_constraints_2', + '620x620', + 'Maximum width and height for largest image for link_type_2.' + ], + [ + 'image_quality', + '100', + 'Used for JPGs and other lossy formats. Enter the percentage quality desired.' + ], + [ + 'watermark_path', + '', + 'Path to the watermark file. Should be a small black and white image.' + ], + [ + 'image_cols', + 'Image1,Image2,Image3,Image4,Image5,Image6,Image7,Image8,Image9,Image10,Image11,Image12,Image13,Image14,Image15,Image16,Image17,Image18,Image19,Image20', + 'Name of image columns, separate with commas' + ], + [ + 'seq_image_cols', + 'Image1_medium,Image2_medium,Image3_medium,Image4_medium,Image5_medium,Image6_medium,Image7_medium,Image8_medium,Image9_medium,Image10_medium,Image11_medium,Image12_medium,Image13_medium,Image14_medium,Image15_medium,Image16_medium,Image17_medium,Image18_medium,Image19_medium,Image20_medium', + 'For the next/previous pager on the showpicture.cgi. The list of columns that can be paged through.' + ], + [ + 'temp_dir', + '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/tmp', + 'Temporary directory for image work' + ], + [ + 'image_url_path', + '/articles/images', + 'URL to the uploaded images. This is the http:// prefixed URL to the directory that will receive all your images.' + ] + ], + 'version' => '1.20100817' + }, + 'UI' => { + 'hooks' => [ + [ + 'build_category', + 'PRE', + 'Plugins::UI::build_category', + '1' + ] + ], + 'meta' => { + 'author' => 'Bao Phan', + 'description' => '', + 'license' => 'Freeware', + 'prog_ver' => '3.3.0', + 'url' => '', + 'version' => '1.0' + }, + 'user' => [ + [ + 'merge_categories', + '4', + 'Category IDs to apply the merging option' + ] + ], + 'version' => '1.0' + }, + 'Widgets' => { + 'menu' => [ + [ + 'Widgets', + 'admin.cgi?do=plugin&plugin=Widgets&func=widgets', + '1' + ] + ], + 'meta' => { + 'author' => 'Bao Phan', + 'description' => '', + 'license' => 'Freeware', + 'prog_ver' => '3.3.0', + 'url' => 'http://gt.net', + 'version' => '1.0' + }, + 'version' => '1.0' + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/Ticker.pm b/site/slowtwitch.com/cgi-bin/articles/admin/Ticker.pm new file mode 100644 index 0000000..e96c32d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/Ticker.pm @@ -0,0 +1,184 @@ +#!/bin/env perl + +# +# This is a simple exception class to aid in error checking and validation. +# +package Ticker::TickerException; +use base qw(Error); +use overload ('""'=>'stringify'); + +sub new { + my $self = shift; + my $text = "" . shift; + my @args = (); + + local $Error::Depth = $Error::Depth + 1; + local $Error::Debug = 1; + + $self->SUPER::new(-text => $text, @args); +} + + +# +# The model (or 'business logic') for the Ticker application. +# +package Ticker; +use strict; +use warnings; +use lib '/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw(:objects); + +# +# Creates the Ticker table. +# +sub create_table() { + my $p = $DB->creator('Ticker'); + $p->cols([ + ticker_id => { type => 'INT', not_null => 1 }, + ticker_text => { type => 'TEXT', not_null => 1}, + ticker_link => { type => 'TEXT', not_null => 1}, + ]); + + $p->pk('ticker_id'); + $p->ai('ticker_id'); + + if(!$p->create and $GT::SQL::errcode eq 'TBLEXISTS') { + $p->set_defaults(); + $p->save_schema(); + } +} + +# +# Validates messages. +# +sub validate_message($) { + my $msg = shift; + unless(defined $msg) { + throw Ticker::TickerException("Message must be defined."); + } + if((length($msg) == 0) || (length($msg) > 255)) { + throw Ticker::TickerException("Message must be between 1 and 255 characters in length."); + } + if($msg !~ /^[\w\s\$\&\.\-\!]+$/) { + throw Ticker::TickerException("Message can only contain letters, numbers, spaces, and the special characters \"\$\& -.!\"."); + } +} + + +# +# Validates links. +# +sub validate_link($) { + my $link = shift; + unless(defined $link) { + throw Ticker::TickerException("Link must be defined."); + } + if((length($link) == 0) || (length($link) > 255)) { + throw Ticker::TickerException("Link must be between 1 and 255 characters in length."); + } + if($link !~ /^http:\/\// && $link !~ /^https:\/\//) { + throw Ticker::TickerException("Links must begin with http:// or https://"); +} +} + + +# +# Validates ids. +# +sub validate_id($) { + my $id = shift; + if($id !~ /^\d+$/) { + throw Ticker::TickerException("Invalid ticker ID."); + } +} + + +# +# Returns a hashref, keyed on the id, of all tickers present in the database. +# +sub read_tickers() { + my $sth = $DB->table('Ticker')->select(); + return $sth->fetchall_hashref('ticker_id'); +} + + +# +# Returns an xml-formatted string of all tickers present in the database. +# +sub read_tickers_xml() { + my $results = read_tickers(); + my $xml = qq{\n}; + $xml .= qq{\n}; + $xml .= ""; + foreach my $v(@$results) { + my $line = qq{\n\t}; + $xml .= $line; + } + $xml .= "\n"; + return $xml; +} + + +# +# Returns a hashref, keyed on the id, of one ticker. +# +sub read_ticker($) { + my ($id) = @_; + + validate_id($id); + + return $DB->table('Ticker')->get($id); +} + + +# +# Adds a ticker to the database, taking the message and link as arguments. +# +sub create_ticker($$) { + my ($msg, $link) = @_; + + validate_message($msg); + validate_link($link); + + return $DB->table('Ticker')->add({ + ticker_text => $msg, + ticker_link => $link + }); +} + + +# +# Update a ticker in the database, taking the old id and new message and +# link as arguments. +# +sub update_ticker($$$) { + my ($id, $msg, $link) = @_; + + validate_id($id); + validate_message($msg); + validate_link($link); + + return $DB->table('Ticker')->modify({ + ticker_id => $id, + ticker_text => $msg, + ticker_link => $link + }); +} + + +# +# Deletes a ticker from the database, taking the id to remove. +# +sub delete_ticker($) { + my ($id) = @_; + + validate_id($id); + + return $DB->table('Ticker')->delete($id); +} + +1; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/admin.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/admin.cgi new file mode 100755 index 0000000..e918439 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/admin.cgi @@ -0,0 +1,297 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: admin.cgi,v 1.94 2009/05/12 01:09:13 brewt Exp $ +# +# Copyright (c) 2005 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 '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +main(); + +sub main { +# ------------------------------------------------------------------ +# Main admin loop, displays html pages and other admin tasks. +# + if (! $CFG->{setup}) { + $IN->param('do', 'page'); + $IN->param('page', 'setup_first.html'); + } + my $do = $IN->param('do') || ''; + my $action = $IN->param('action') || ''; + +# Default to home page. + unless ($do or $action) { + if ($IN->param('page')) { + $do = 'page'; + } + else { + $IN->param('page', 'home.html'); + $do = 'page'; + } + } + +# Otherwise, try some common cases. + CASE: { + ($do eq 'page') and Links::admin_page(), last CASE; + ($do eq 'help') and help(), last CASE; + ($do eq 'plugin') and plugin(), last CASE; + ($do eq 'fileman') and fileman(), last CASE; + ($do eq 'fileman_diff') and fileman_diff(), last CASE; + +# Database Browser + $do and db_request() and last CASE; + +# Category Browser. + $action and brow_request() and last CASE; + +# Mass Mailer + $action and mailer_request() and last CASE; + +# Invalid method. + die "Invalid Request: '$do' '$action'"; + } +} + +sub db_request { +# ------------------------------------------------------------------ +# Handles a GT::SQL::Admin request. +# + require Links::Admin; + my $admin = new Links::Admin; + + if ($admin->for_me($IN)) { + $admin->debug_level( $CFG->{debug_level} ); + $admin->process ( db => $DB, cgi => $IN ); + return 1; + } + else { + return; + } +} + +sub brow_request { +# ------------------------------------------------------------------ +# Handle the browser request. +# + $IN->delete('anticache'); + +# Get a controller to manage access. + require Links::Browser; + my $crtl = new Links::Browser::Controller; + +# Load the tree if it is under 200 categories. + $crtl->{load_tree} = 1; + $crtl->{admin} = 1; + $crtl->{admin_templates} = 1; + +# Begin the script. + my $method = $crtl->can_run; + if ($method) { + my $browser = new Links::Browser(ctrl => $crtl); + $PLG->dispatch("browser_$method", sub { $browser->$method(); }, $browser); + return 1; + } + else { + return; + } +} + +sub mailer_request { +# ------------------------------------------------------------------ +# Determine if this is for the Links::MassMailer. +# + require Links::MassMailer; + my $action; + my @actions = $IN->param('action'); + if (@actions > 1) { + @actions = grep ! /^(?:Send|selected_(?:users|links)_send)$/, @actions; + } + $action = $actions[0]; + + $action = "SaveAs" if $action eq "Save as..."; # No spaces or .'s allowed in subroutine names! + if (exists $ACTIONS::{$action} and ref *{$ACTIONS::{$action}}{CODE} eq 'CODE') { + *{$ACTIONS::{$action}}{CODE}->(); + return 1; + } + else { + return; + } +} + +sub help { +# ------------------------------------------------------------------ +# Print the help pages. +# + my $help_path = "$CFG->{admin_root_path}/templates/admin/help"; + my $topic = $IN->param('topic'); + if (! $topic) { + my $url = $IN->param('topic_url'); + my ($do) = $url =~ /do=([^&]+)/; + my ($page) = $url =~ /page=([^&]+)/; + my ($cgi) = $url =~ /([^\/]+)\.cgi/; + + if ($do and $do eq 'plugin') { + my ($plugin) = $url =~ /plugin=([^&]+)/; + my ($func) = $url =~ /func=([^&]+)/; + if ($topic = _plugin_help($plugin, $func)) { + $help_path .= "/$plugin"; + } + } + else { + $topic = _parse_topic($page || ''); + $topic ||= _parse_topic($do || ''); + $topic ||= _parse_topic($cgi || ''); + } + } + $topic ||= 'help_toc.html'; + $topic =~ s,^/|/$,,; + +# Check the topic file. + unless ($topic =~ /^[\w\/]+\.[\w]+$/) { + die "Invalid topic: $topic"; + } + if ($topic =~ /\.(gif|jpg)$/ and -e "$help_path/$topic") { + print $IN->header("image/$1"); + open IMG, "< $help_path/$topic" or die "Unable to open image help: $help_path/$topic ($!)"; + binmode IMG; + binmode STDOUT; + while (read (IMG, my $buffer, 65356)) { + print $buffer; + } + close IMG; + } + else { + print $IN->header; + GT::Template->parse($topic, $IN, { root => $help_path, print => 1 }); + } +} + +sub plugin { +# ------------------------------------------------------------------ +# Run a plugin function. +# + my $plugin = $IN->param('plugin'); + if ($IN->param('download') and ($plugin =~ /^[\w\-]+$/)) { + my $path = "$CFG->{admin_root_path}/Plugins/Uninstalled/$plugin.tar"; + -e $path or die "No plugin ($path) found."; + open FH, $path or die "Could not open $path for reading"; + print $IN->header($IN->file_headers( + filename => "$plugin.tar", + mimetype => 'application/x-tar', + inline => 0, + size => -s $path + )); + print while ; + close FH; + return 1; + } + my $func = $IN->param('func'); + { + eval { require "Plugins/$plugin.pm"; }; + if ($@) { + die "Unable to load plugin: $plugin ($@)"; + } + } + no strict 'refs'; + my $code = ${"Plugins::" . $plugin . "::"}{$func}; + use strict 'refs'; + + if (!defined $code) { + die "Invalid plugin function: $func"; + } + $code->(); +} + +sub fileman { +# ------------------------------------------------------------------ +# Load our file manager. +# + + require GT::FileMan; + my $fileman = GT::FileMan->new( + cfg => { + template_root => "$CFG->{admin_root_path}/templates/admin/fileman", + tmp_path => "$CFG->{admin_root_path}/tmp", + root_path => $CFG->{fileman_root_dir} || $CFG->{admin_root_path}, + cgi_url => "$CFG->{admin_root_url}/admin.cgi", + static_url => "$CFG->{build_static_url}/fileman", + debug_level => $CFG->{debug_level}, + }, + url_opts => 'do=fileman' + ); + $fileman->process; +} + +sub fileman_diff { +# ------------------------------------------------------------------ +# Load fileman, but just for the purposes of displaying a diff. +# + my $template = $IN->param('template'); + my $file = $IN->param('file'); + + require GT::FileMan::Diff; + my $diff = GT::FileMan::Diff::html_diff("$CFG->{admin_root_path}/templates/$template/$file", "$CFG->{admin_root_path}/templates/$template/local/$file", 3); + + print $IN->header(); + print '' . $IN->html_escape($template) . ' template diffs: ' . $IN->html_escape($file) . ''; + if (ref $diff) { + print $$diff; + } + else { + print "File(s) not found."; + } + print ''; +} + +sub _parse_topic { +# ------------------------------------------------------------------ +# Takes a keyword and tries to find a help page for it. +# + local $_ = shift; + CASE: { + /browse/ and return 'help_browse.html'; + /build/ and return 'help_build.html'; + /email/ and return 'help_email.html'; + /mailer/ and return 'help_email.html'; + /payment/ and return 'help_payments.html'; + /plugin_editor/ and return 'help_plugin_guide.html'; + /plugin_list/ and return 'help_plugin_manager.html'; + /plugin/ and return 'help_plugins.html'; + /db/ and return 'help_database.html'; + } + return; +} + +sub _plugin_help { +# ------------------------------------------------------------------ + my ( $plugin, $func ) = @_; + my $help_path = "$CFG->{admin_root_path}/templates/help/$plugin"; + + -e $help_path or return; + + if ( -e "$help_path/$func.html" ) { + return "$func.html"; + } + elsif ( -e "$help_path/help.html" ) { + return "help.html"; + } + + return; +} + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/bases.pm b/site/slowtwitch.com/cgi-bin/articles/admin/bases.pm new file mode 100644 index 0000000..5dd55e8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/bases.pm @@ -0,0 +1,109 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# bases +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== + +package bases; + +use strict 'subs', 'vars'; + +sub import { + my $class = shift; + my $pkg = caller; + my $hsh = {@_}; + my @indices = map { $_[$_ * 2] } 0 .. $#_ * 0.5; + foreach my $base (@indices) { + next if $pkg->isa($base); + push @{"$pkg\::ISA"}, $base; + my $args = ''; + if (my $ref = ref $hsh->{$base}) { + require GT::Dumper; + if ($ref eq 'ARRAY') { + $args = '(@{' . GT::Dumper->dump_structure($hsh->{$base}) . '})'; + } + else { + $args = '(' . GT::Dumper->dump_structure($hsh->{$base}) . ')'; + } + } + elsif (defined $hsh->{$base}) { + $args = $hsh->{$base} eq '' ? '()' : "qw($hsh->{$base})"; + } + my $dcl = qq| + package $pkg; + use $base $args; + |; + eval $dcl; + die "$@: $dcl" if $@ && $@ !~ /^Can't locate .*? at \(eval /; + unless (%{"$base\::"}) { + require Carp; + Carp::croak( +qq|Base class package "$base" is empty. +String: +$dcl +\t(Perhaps you need to 'use' the module which defines that package first.)| + ); + } + } +} + +1; + +__END__ + +=head1 NAME + +base - Establish IS-A relationship with base class at compile time. + +=head1 SYNOPSIS + + package Baz; + use bases + Foo => ':all', + Bar => '' + Bat => undef; + +=head1 DESCRIPTION + +Roughly similar in effect to + + package Baz; + use Foo qw(:all); + use Bar(); + use Bat; + BEGIN { @ISA = qw(Foo Bar Bat) } + +This is very similar to C pragma except %FIELDS is not +supported and you are able to pass parameters to import on the +module that is used in this way. + +If the value specified is undef, the module being used import method +will be called if it exists. If the value is an empty string, import +will not be called. + +When strict 'vars' is in scope I also let you assign to @ISA +without having to declare @ISA with the 'vars' pragma first. + +If any of the base classes are not loaded yet, I silently +Cs them. Whether to C a base class package is +determined by the absence of a global $VERSION in the base package. +If $VERSION is not detected even after loading it, will +define $VERSION in the base package, setting it to the string +C<-1, set by bases.pm>. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/bin/test.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/bin/test.cgi new file mode 100755 index 0000000..cad3173 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/bin/test.cgi @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: admin.cgi,v 1.94 2009/05/12 01:09:13 brewt Exp $ +# +# Copyright (c) 2005 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 '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +use Plugins::MostPopular; +use Links::SiteHTML; + +my $foo = Plugins::MostPopular::generate_popular_links(); + +use Data::Dumper; +foreach (@{$foo->{MostPopularLinks}}) { + print $_->{Title}, "\n"; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/bin/upimages b/site/slowtwitch.com/cgi-bin/articles/admin/bin/upimages new file mode 100755 index 0000000..d0eb334 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/bin/upimages @@ -0,0 +1,53 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: admin.cgi,v 1.94 2009/05/12 01:09:13 brewt Exp $ +# +# Copyright (c) 2005 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 '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; +use GT::File::Tools qw/:all/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +my $tab_files = $DB->table('Links_Files'); +my $files = $tab_files->select()->fetchall_hashref; +for (@$files) { + my $fletter = ( reverse split //, $_->{ID} )[0]; + my $path = "$_->{File_Directory}/$fletter"; + my $escaped_name = $IN->escape($_->{File_Name}); + unless(-f "$path/$_->{ID}-$escaped_name") { + if (-f "$path/$_->{ID}-$_->{File_Name}") { + $tab_files->update({ File_Name => $IN->unescape($_->{File_Name}) }, { ID => $_->{ID} }); + } + elsif ($_->{File_Directory} eq '/var/home/slowtwitch/slowtwitch.com/www/articles/images') { + if (-f "/var/home/slowtwitch/slowtwitch.com/www/articles/images.bad/$fletter/$_->{ID}-$_->{File_Name}") { + copy("/var/home/slowtwitch/slowtwitch.com/www/articles/images.bad/$fletter/$_->{ID}-$_->{File_Name}", "$path/$_->{ID}-$_->{File_Name}"); + print "not escape $_->{File_Name}: FOUND\n"; + } + elsif (-f "/var/home/slowtwitch/slowtwitch.com/www/articles/images.bad/$fletter/$_->{ID}-$escaped_name") { + print "escaped $escaped_name: FOUND\n"; + } + elsif ("/var/home/slowtwitch/slowtwitch.com/www/missing_files/$_->{File_Name}") { + print "$path/$_->{ID}-$_->{File_Name}\n"; + move("/var/home/slowtwitch/slowtwitch.com/www/missing_files/$_->{File_Name}", "$path/$_->{ID}-$_->{File_Name}"); + } + } + else { + # print "$path/$_->{ID}-$_->{File_Name}\n"; + } + } +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/build_backup.pl b/site/slowtwitch.com/cgi-bin/articles/admin/build_backup.pl new file mode 100755 index 0000000..53184b9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/build_backup.pl @@ -0,0 +1,40 @@ +#!/usr/local/bin/perl + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use vars qw/$USE_HTML $TIME_START $TOTAL_TIME @CARP_NOT $GRAND_TOTAL/; +use Links qw/:objects :payment/; +use Links::Build; + +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { +# ------------------------------------------------------------------- +# + _build_backup(); +} + +sub _build_backup { +# ------------------------------------------------------------------ +# Create a backup file in our backup directory. +# + print "Creating backup file...\n"; + require Links::Import::S2BK; + + my $max_keep = 7; + my $root = $CFG->{admin_root_path} . '/backup'; + my $filename = 'BACKUP'; + + for my $n (reverse 0 .. $max_keep) { + my $oldname = join '.', $filename, $n || (); + my $newname = join '.', $filename, $n+1; + if (-e "$root/$oldname") { + rename "$root/$oldname", "$root/$newname" or print "\tCouldn't rename '$root/$oldname' -> '$root/$newname': $!"; + } + } + Links::Import::S2BK::import({ source => "$CFG->{admin_root_path}/defs", destination => "$root/$filename", delimiter => "\t" }, sub { print "\n\tWARNING: @_\n" }, sub { die @_ }, sub { print "\n\tWARNING: @_\n" }, sub { }); + print "Done\n"; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/checksums.dat b/site/slowtwitch.com/cgi-bin/articles/admin/checksums.dat new file mode 100644 index 0000000..c113ba2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/checksums.dat @@ -0,0 +1,714 @@ +{ + 'cgi/add.cgi' => '4320121d831c02fae6ffdf7054ebf097', + 'cgi/admin/GT/AutoLoader.pm' => 'c5b5ca16f2e46685e6543d87cdb5392e', + 'cgi/admin/GT/Base.pm' => '7a5fd5c740eee1cc4d3329875a1003f0', + 'cgi/admin/GT/CGI.pm' => 'df43f3b51273b43af029b2f117ef1ad7', + 'cgi/admin/GT/CGI/Action.pm' => 'f0285065533fa182c09d01f424df9bea', + 'cgi/admin/GT/CGI/Action/Common.pm' => 'c1845085fd879e6a485bdaa2a0ab7d56', + 'cgi/admin/GT/CGI/Action/Plugin.pm' => '7bac3bd00129500028f651ae28b57772', + 'cgi/admin/GT/CGI/Cookie.pm' => 'c7c7ba6bcd4c48a35a17f1f5e1f97c5e', + 'cgi/admin/GT/CGI/EventLoop.pm' => 'db317ebe1148e45ff965e321d30633e5', + 'cgi/admin/GT/CGI/Fh.pm' => '22452d85711ad1330a722c5c020c4bf2', + 'cgi/admin/GT/CGI/MultiPart.pm' => '99103c2cc3b228df8b276399498fdcbc', + 'cgi/admin/GT/Cache.pm' => '2bdb9b8828a011aaa1c70d1e9c8eea11', + 'cgi/admin/GT/Config.pm' => '907a25f5f99054fb670f863ecf308711', + 'cgi/admin/GT/Date.pm' => '744b7fa27c5783ce5935c9a4fdf1d87b', + 'cgi/admin/GT/Delay.pm' => 'c6c2f51a0082c777f9e86e12a74e909c', + 'cgi/admin/GT/Dumper.pm' => '28f758e79fcfaf010a7ca8c891f31462', + 'cgi/admin/GT/File/Diff.pm' => '3f85d9ed208c00ab07bbede1163ba185', + 'cgi/admin/GT/File/Tools.pm' => '6c9528dfa792ba8db0bb7ad2e5557d6c', + 'cgi/admin/GT/FileMan.pm' => 'f4d05bc0ae743c3ba8dcfc4ffc866e23', + 'cgi/admin/GT/FileMan/Commands.pm' => '8a671af2c9be5a587673c69724c118f9', + 'cgi/admin/GT/FileMan/Diff.pm' => '4e7e534434d6ba865a82043683fa17c8', + 'cgi/admin/GT/FileMan/Session.pm' => '9a344b8b7b5415b3d33e2b1aa633fcbb', + 'cgi/admin/GT/IPC/Filter.pm' => '2d3f9f54c66ec6ab30a28cf7f3f6e152', + 'cgi/admin/GT/IPC/Filter/Block.pm' => 'd94e9977e10691916c3b7ceddadd44d9', + 'cgi/admin/GT/IPC/Filter/Line.pm' => '1cd21ea4523dffc92516eb610feb0b8e', + 'cgi/admin/GT/IPC/Filter/Stream.pm' => '40f29fab19336b93afd8cfb85de16d05', + 'cgi/admin/GT/IPC/Run.pm' => '051f84840a0997bde0afe2d16bd49d41', + 'cgi/admin/GT/IPC/Run/Child.pm' => 'ee46511ab9980e67273dd5790ad92048', + 'cgi/admin/GT/IPC/Run/Select.pm' => '2c4e647e87fa91cb27bd33c28839639e', + 'cgi/admin/GT/IPC/Run/Unix.pm' => '6dcb89e0ff46da98e6130a1eda904023', + 'cgi/admin/GT/IPC/Run/Win32.pm' => '9000fbe013cf40894225b0c2fbe89c43', + 'cgi/admin/GT/IPCountry.pm' => 'b4df95ffdf83ec1b9cf0a006fec9fd34', + 'cgi/admin/GT/Image/Security.pm' => '44d42081dd0dbdc128dfe9739f3f37b8', + 'cgi/admin/GT/Image/Size.pm' => '8d5d2274b11fd5503add14b87012ed92', + 'cgi/admin/GT/JSON.pm' => '94347d06fa324517fc3b07a42358228f', + 'cgi/admin/GT/JSON/PP.pm' => '9168d6dcafe78f0576d4bcf73e59b5b2', + 'cgi/admin/GT/JSON/PP/Boolean.pm' => 'f1450b0535492bd7afceb99885156348', + 'cgi/admin/GT/JSON/PP5005.pm' => 'a5d4056de6cd602df92fd73c14b801d2', + 'cgi/admin/GT/JSON/PP56.pm' => 'f8d2098143bb2464d0fb68e218049d6c', + 'cgi/admin/GT/JSON/PP58.pm' => '57e820fc2387475094bbf3d42a3a123c', + 'cgi/admin/GT/Lock.pm' => 'd459e55b50b81e8c5d6c8ecec42e6b49', + 'cgi/admin/GT/MD5.pm' => '322c52d2b03dd8888d87b7fccc15119e', + 'cgi/admin/GT/MD5/Crypt.pm' => 'c6062c015cbcc3737588e7e4a2366ff3', + 'cgi/admin/GT/MIMETypes.pm' => '3f7312844abbc8938645593c09c8a18a', + 'cgi/admin/GT/Mail.pm' => '2fd868f60bcba291cff20ca84918278b', + 'cgi/admin/GT/Mail/BulkMail.pm' => '2f5ac46345a58177bfe80b3dfffff61d', + 'cgi/admin/GT/Mail/Editor.pm' => '3b602f730cc015c9abcfd8364122dc90', + 'cgi/admin/GT/Mail/Editor/HTML.pm' => 'a7475873e6619c8e6a24d7bf5930e1dc', + 'cgi/admin/GT/Mail/Editor/Text.pm' => 'd6a8bc77e4784e2383f6fa3907732cee', + 'cgi/admin/GT/Mail/Encoder.pm' => '6e0e59f5a6f5cf0247bf7c86dfc772a2', + 'cgi/admin/GT/Mail/POP3.pm' => 'c0fbab4ac82868f3630978dfe52a195e', + 'cgi/admin/GT/Mail/Parse.pm' => '22bd03b68c2123f519b551ce838f9893', + 'cgi/admin/GT/Mail/Parts.pm' => 'f83c3af7224981e2d0da71aa5fd11970', + 'cgi/admin/GT/Mail/Send.pm' => '1ee296640ef811aabe02cd72cb74cd62', + 'cgi/admin/GT/Maildir.pm' => 'ceb842c8164f8410fedc4858b34f1f4e', + 'cgi/admin/GT/Maildir/Folder.pm' => '279c7129f350c9f9201da41e455bd2bd', + 'cgi/admin/GT/Maildir/FolderTree.pm' => '17bcef8d5af5dda076ca1268c7f3011b', + 'cgi/admin/GT/Maildir/FolderTree/Dir.pm' => 'e4fec6955b05a300bbf2e648d47ce082', + 'cgi/admin/GT/Maildir/Folders.pm' => '77f9348ccb2702a031d7eef8f84c74be', + 'cgi/admin/GT/Maildir/Indexer.pm' => 'e864771847f72556040981599029f1ed', + 'cgi/admin/GT/Maildir/Lock.pm' => '7b61577fce61e15fe2239d3ebf6fb53a', + 'cgi/admin/GT/Maildir/Lock/NFSLock.pm' => 'ef9771a16aa18e4f0c32d4c111ca7286', + 'cgi/admin/GT/Maildir/Lucene.pm' => 'd30de25b8015f4586bb09c16e78e9fe5', + 'cgi/admin/GT/Maildir/Lucene/Indexer.pm' => 'a1eb3150e56e547c26937904f94497f3', + 'cgi/admin/GT/Maildir/Lucene/Indexer/Analyzer.pm' => '7717b6107c87f6a482e7f37f512afc7a', + 'cgi/admin/GT/Maildir/Lucene/Indexer/Tokenizer.pm' => '966f61a6ecdae331c3d1ed80d3ea3bb1', + 'cgi/admin/GT/Maildir/Lucene/Searcher.pm' => '0548aa398ff45e1f3ce37b7a5302bbe6', + 'cgi/admin/GT/Maildir/Lucene/Searcher/Results.pm' => '5cff466f98a1f49b10995320c556cdbe', + 'cgi/admin/GT/Maildir/Quota.pm' => 'ae2e818018a60b7f7370cae4a622ef06', + 'cgi/admin/GT/Maildir/Search/Query.pm' => 'f7ee61145d548386b28b2a7cb899e61b', + 'cgi/admin/GT/Maildir/Search/Sort.pm' => 'ea6c307450d2b93c57a885248f89e8ca', + 'cgi/admin/GT/Maildir/Search/SortField.pm' => 'e31db35a96cdf25d33154091cd4d65e7', + 'cgi/admin/GT/Maildir/Search/SortGroup.pm' => '4063ce86dab3d322b18881235af744de', + 'cgi/admin/GT/Maildir/Search/Term.pm' => '24c3b5bfa4639c296d3caccc343d7c2a', + 'cgi/admin/GT/Maildir/Searcher.pm' => 'f902f154dd09190a927cd421f67027c1', + 'cgi/admin/GT/Maildir/Searcher/Results.pm' => '7e0db94f1a7bf4dbb7637e16fb6b8200', + 'cgi/admin/GT/Payment/Direct/AuthorizeDotNet.pm' => '2db43f79dc83402dae7f91f516c0e1c4', + 'cgi/admin/GT/Payment/Direct/Moneris.pm' => '61757bdf3bf14e01bac3c5cac451af09', + 'cgi/admin/GT/Payment/Remote/2CheckOut.pm' => 'afbf089c03989b1cd5a9f8c6f86f15b4', + 'cgi/admin/GT/Payment/Remote/PayPal.pm' => 'bf2262bf2b6338fc1aa0451bd4fe7938', + 'cgi/admin/GT/Payment/Remote/WorldPay.pm' => 'c587a0625368e935e3f9875e7e50b3ed', + 'cgi/admin/GT/Plugins.pm' => 'c0b647012f4ce0e7062c942c7571db51', + 'cgi/admin/GT/Plugins/Author.pm' => '86560acb26c45641eb57db94af436d62', + 'cgi/admin/GT/Plugins/Installer.pm' => 'b92d77a75376b751812bef7d1fed6bc8', + 'cgi/admin/GT/Plugins/Manager.pm' => '314674ac29f31591b9521e0a67ef4be3', + 'cgi/admin/GT/Plugins/Wizard.pm' => '414345d8d7f3d1b800f5b87c9deaea7d', + 'cgi/admin/GT/RDF.pm' => 'ead31202b3a195410acd6dfdd4a05649', + 'cgi/admin/GT/SQL.pm' => '4d541865b9003b275f8e66983337f090', + 'cgi/admin/GT/SQL/Admin.pm' => '47d56336f74cb9a6263b9713f9684e48', + 'cgi/admin/GT/SQL/Base.pm' => '94f0d4f1d2a787de124c392c23bf8d98', + 'cgi/admin/GT/SQL/Condition.pm' => '33a8c5cc54b3e5ab50b7cf826cd124cc', + 'cgi/admin/GT/SQL/Creator.pm' => 'deea999b5558f79700f6330de1bf2628', + 'cgi/admin/GT/SQL/Display/HTML.pm' => '2bd2c377aa09f54404f922fc37711eb4', + 'cgi/admin/GT/SQL/Display/HTML/Relation.pm' => '7aec3ed4d965a60f7ee85af1a472994f', + 'cgi/admin/GT/SQL/Display/HTML/Table.pm' => 'eb113347a5cbae19fdbc57a7a0db9b21', + 'cgi/admin/GT/SQL/Driver.pm' => 'ddcba7e36bedefa51502bbc5bc969f0c', + 'cgi/admin/GT/SQL/Driver/MSSQL.pm' => '6e84a0c0af0005c7a5acf1a8c77a1e46', + 'cgi/admin/GT/SQL/Driver/MYSQL.pm' => '7c4e8369d73b4974eede6ed8ca8bb018', + 'cgi/admin/GT/SQL/Driver/ORACLE.pm' => 'cb454b481d6c6d66261ef07a87df09f2', + 'cgi/admin/GT/SQL/Driver/PG.pm' => '60eb5bb0afc2438eb6044d99400acc13', + 'cgi/admin/GT/SQL/Driver/Types.pm' => '54a03159bbe04c94d6937a4556b1aed0', + 'cgi/admin/GT/SQL/Driver/debug.pm' => 'fbfe87cb77606ca23aabbd9a33554ea5', + 'cgi/admin/GT/SQL/Driver/sth.pm' => '19e1e08605c7c427b9f782d56900ca2c', + 'cgi/admin/GT/SQL/Editor.pm' => '9921499e6abbbea2865c85f11e1836cd', + 'cgi/admin/GT/SQL/File.pm' => '66cd1008d14a3154bfac1c2ea79073ae', + 'cgi/admin/GT/SQL/Monitor.pm' => 'a37e62a6f80c98529e65bea053f9a858', + 'cgi/admin/GT/SQL/Relation.pm' => '22a635fe513a1413e92656a11f9fca6b', + 'cgi/admin/GT/SQL/Search.pm' => 'f3d20ab2f7203f3ee471d65fe4bb39c2', + 'cgi/admin/GT/SQL/Search/Base/Common.pm' => '6ca2ca58af3068587cf0f09a5e460ce5', + 'cgi/admin/GT/SQL/Search/Base/Indexer.pm' => '4601df9b013903d69d1e9d6df409c0a8', + 'cgi/admin/GT/SQL/Search/Base/STH.pm' => '3c793c0b5205f8d480f14aa9f54111b4', + 'cgi/admin/GT/SQL/Search/Base/Search.pm' => '0b08ebdcd723d263b263bcbf457fb100', + 'cgi/admin/GT/SQL/Search/INTERNAL/Indexer.pm' => '7fcf1eae39a79cc07e6afd6620398d73', + 'cgi/admin/GT/SQL/Search/INTERNAL/Search.pm' => '497617d982fc476baa1b0e82b5853bb7', + 'cgi/admin/GT/SQL/Search/LUCENE/Indexer.pm' => 'a146a1d681d90099ae5feb7ad6ddf77e', + 'cgi/admin/GT/SQL/Search/LUCENE/STH.pm' => 'eef94fa4252b743314eb44e6180c9b71', + 'cgi/admin/GT/SQL/Search/LUCENE/Search.pm' => '054269d062078d780277e2f3b7d06e74', + 'cgi/admin/GT/SQL/Search/MSSQL/Indexer.pm' => '045ef2cabb8feb8c7c5c9b13e7e7e536', + 'cgi/admin/GT/SQL/Search/MSSQL/Search.pm' => 'fec24ea7bffc2f114cb2f3da53aa7da6', + 'cgi/admin/GT/SQL/Search/MYSQL/Indexer.pm' => '723070eb819844601b276727bbda0b0e', + 'cgi/admin/GT/SQL/Search/MYSQL/Search.pm' => '173950860f7395e886577c481779a0ff', + 'cgi/admin/GT/SQL/Search/MYSQL/VER3.pm' => '941e860312143f5cac5092c5d53bda9b', + 'cgi/admin/GT/SQL/Search/MYSQL/VER4.pm' => '0a05ddb63bf2e1f79aedea8d10357217', + 'cgi/admin/GT/SQL/Search/NONINDEXED/Indexer.pm' => 'db73a0c3323d94106760d711ed7c10cc', + 'cgi/admin/GT/SQL/Search/NONINDEXED/Search.pm' => '329cc2076bcc3c912d2d76c506a81ef6', + 'cgi/admin/GT/SQL/Table.pm' => 'e4b3bed59e019670a028a03bb78e52ef', + 'cgi/admin/GT/SQL/Tree.pm' => '4ce04aa48374f5d9cdd2afcac3457a81', + 'cgi/admin/GT/SQL/Tree/Rebuild.pm' => '34b7b7b3d993670b0d81a61fef742d2f', + 'cgi/admin/GT/SQL/Types.pm' => 'ea7b325b7baffdecfc670c97b5c09d88', + 'cgi/admin/GT/SQL/Upgrade.pm' => 'e7cec398ec287c172edb1c10c8742f56', + 'cgi/admin/GT/Session/File.pm' => 'ae2b4dd098a63a9b48583bf8d39a6eff', + 'cgi/admin/GT/Session/SQL.pm' => '93d1ade50f7f13085cda166662a5fd59', + 'cgi/admin/GT/Session/TempTable.pm' => '33fe99049c4e5b0032149b2bf974698c', + 'cgi/admin/GT/Socket.pm' => 'e3607ae9905b1783e5a614b154016d07', + 'cgi/admin/GT/Socket/Client.pm' => '9687ddc8880543185930ec67ff13bd70', + 'cgi/admin/GT/Socket/Client/SSLHandle.pm' => 'd3b7e6f000f4a9428ce9eb39daf7edf4', + 'cgi/admin/GT/Tar.pm' => '9daf44c6a6e631b1e2b6576d028df3cf', + 'cgi/admin/GT/TempFile.pm' => '723fe79f2e90ff880ea1440c38c1c164', + 'cgi/admin/GT/Template.pm' => '522ff1cc0f9317375613d2a74de9af82', + 'cgi/admin/GT/Template/Editor.pm' => '6e2a8b9d81d19b9554a70143bf2c0bd3', + 'cgi/admin/GT/Template/Inheritance.pm' => '466788efcec6905e24addd81c5040170', + 'cgi/admin/GT/Template/Parser.pm' => '6f74f75dbc01d0bc9c4ce4b27aa3663b', + 'cgi/admin/GT/Template/Vars.pm' => '15779bff2a3cb2cac4879afd9330e7a9', + 'cgi/admin/GT/Text/Tools.pm' => 'ff16b999685652a9489e2c203b941504', + 'cgi/admin/GT/URI.pm' => 'ce24ecd93dc578535eded4b920541556', + 'cgi/admin/GT/URI/HTTP.pm' => '41fcf01db846bd3e2bbc72145e792b7f', + 'cgi/admin/GT/URI/HTTPS.pm' => 'b9084f28c71bb05ca03e5400c284a287', + 'cgi/admin/GT/Update.pm' => 'ec47c2a02bb4495b9407088508b9b86b', + 'cgi/admin/GT/WWW.pm' => 'fca38575a98a18a84c3f03bbed2fc554', + 'cgi/admin/GT/WWW/http.pm' => '272ec1b74e062129853f2aeebf8bb76e', + 'cgi/admin/GT/WWW/http/Header.pm' => '52c3d543f90563bc988b3d9e2b9cc1a7', + 'cgi/admin/GT/WWW/http/Response.pm' => '3f7aef8e8917b8548efc9d1412cf6cc3', + 'cgi/admin/GT/WWW/https.pm' => 'd32c34bda5acde0f4ec409d81d4937a2', + 'cgi/admin/Links.pm' => 'f1f98dede8f23dfae2644cd219036120', + 'cgi/admin/Links/Admin.pm' => '0e2240ffb59547008bbcaf8b50465e03', + 'cgi/admin/Links/Authenticate.pm' => 'db9f41fb48c75d93285b4341bb63243c', + 'cgi/admin/Links/Bookmark.pm' => '4816602d08dcf19d76d2a6b61e9bf7df', + 'cgi/admin/Links/Browser.pm' => '608820b5796a7c92057ccb59b9c0a691', + 'cgi/admin/Links/Browser/Controller.pm' => '0ec37c162a020e663d59ce209e9723f5', + 'cgi/admin/Links/Browser/JFunction.pm' => '421c6fbf16268fc18522369a0cbbeef1', + 'cgi/admin/Links/Build.pm' => '6f6444d186d5eb43c2339b6732eae36c', + 'cgi/admin/Links/Config.pm' => '0979b023df7474c285f2e7542091e189', + 'cgi/admin/Links/Config/Updates.pm' => '784f8dbd7bc77b51e806109981b501a7', + 'cgi/admin/Links/HTML/Category.pm' => '9d49ea0f465bc137a7fd49ed354f7d50', + 'cgi/admin/Links/HTML/Links.pm' => 'f19edd251a58f344f9c04e6c23eee4d5', + 'cgi/admin/Links/HTML/Users.pm' => '17449e04e8606ad9d726fae71538472e', + 'cgi/admin/Links/Import/BKS2.pm' => '06f6d0ec9d0d184bc56d9b36913a9d1c', + 'cgi/admin/Links/Import/Interface/CGI.pm' => '51445e4b8f450bcf787c0390fb9143ec', + 'cgi/admin/Links/Import/Interface/Text.pm' => '0929a6ca32ab3058eb56ae1da3b4d963', + 'cgi/admin/Links/Import/L1S2.pm' => '4460ea0449078278b86058ab88f7cc7b', + 'cgi/admin/Links/Import/L2S2.pm' => 'e9feca7a8be7f9f8fef7c6ef404c3f6c', + 'cgi/admin/Links/Import/RDFS2.pm' => '90b0798174ad02ff4a3bed2c7c23da24', + 'cgi/admin/Links/Import/S1S2.pm' => 'e5f31f4aad8c34220e84caaf7f86d8fc', + 'cgi/admin/Links/Import/S2BK.pm' => 'b4f7c02a04218d467fff7a253c11f3aa', + 'cgi/admin/Links/MassMailer.pm' => '4e461a2fa5a3186010d282eafca38646', + 'cgi/admin/Links/Newsletter.pm' => '3e85168c25dce88f49b4b04a03c62846', + 'cgi/admin/Links/Parallel.pm' => 'ba3c7dfa962ae14c1e494121de1a4b0a', + 'cgi/admin/Links/Payment.pm' => '44d4242542d8d5aa56bfd14cd5ab7ed8', + 'cgi/admin/Links/Payment/Direct/AuthorizeDotNet.pm' => '967cdde1e57efba21e23e38164538888', + 'cgi/admin/Links/Payment/Direct/Moneris.pm' => '48b34496440346e0fb4e312b6e839a95', + 'cgi/admin/Links/Payment/Remote/2CheckOut.pm' => 'fa30f9fde52c033a97ea1848394841c9', + 'cgi/admin/Links/Payment/Remote/Manual.pm' => 'afa901f798deabfe8945b18facf9c38a', + 'cgi/admin/Links/Payment/Remote/PayPal.pm' => '0ded83c2f878d7dfb6538a8e290fd378', + 'cgi/admin/Links/Payment/Remote/WorldPay.pm' => '9880c41babe23d29bbeb398e2a51ebfe', + 'cgi/admin/Links/Plugins.pm' => 'cce70103fd97eafd9e717fa24e89125e', + 'cgi/admin/Links/SQL.pm' => 'b7b337f88cc3cdfb863bef47054441f5', + 'cgi/admin/Links/SiteHTML.pm' => '5f8324c5db25de7813d124c7641c8da1', + 'cgi/admin/Links/Table/CatLinks.pm' => '11615338cba1574481108f9b6cf266ad', + 'cgi/admin/Links/Table/Category.pm' => '65ff863b8bd13726a661a6543696bf25', + 'cgi/admin/Links/Table/ClickTrack.pm' => '563bb6e3188ad61b219406d91c06da3a', + 'cgi/admin/Links/Table/Links.pm' => '12a7a18fc44ec708341cec4fb477a8ed', + 'cgi/admin/Links/Table/Reviews.pm' => '4104a437785299e3aefa84e329d4c969', + 'cgi/admin/Links/Table/Users.pm' => '86ee463f6d395fa732089212100a100e', + 'cgi/admin/Links/Tools.pm' => '829f39cb8abaec137ba8f7bf6fa14b53', + 'cgi/admin/Links/Update.pm' => '61fb3ced8b2d18f8366d3dbb643bf560', + 'cgi/admin/Links/Upgrade.pm' => 'a1ca51886eb5f4ad6ef4955f41bd09a8', + 'cgi/admin/Links/User/Add.pm' => 'd1a94188a4011d5c1488335a66d58fe1', + 'cgi/admin/Links/User/Editor.pm' => 'd7862de6a12ab5f2aad3ba1747860237', + 'cgi/admin/Links/User/Jump.pm' => 'ec955b661d26feb06d887c4355b927a0', + 'cgi/admin/Links/User/Login.pm' => 'eda1faa89671cc374ec63ebb1b1b8d73', + 'cgi/admin/Links/User/Modify.pm' => '2f42b822b1e943683fb0dc188701d16b', + 'cgi/admin/Links/User/Page.pm' => '33021750fd7b8a315494d4ae7a5ddbd7', + 'cgi/admin/Links/User/Rate.pm' => 'b39688309491c1585f0ef4fe73c65505', + 'cgi/admin/Links/User/Review.pm' => 'dd91def4d550bac4ade0bc1a89d0d59f', + 'cgi/admin/Links/User/Search.pm' => '957d1b9989c920034c6bfaffce1930fc', + 'cgi/admin/Links/User/Treecats.pm' => '0564167f46daac5e59e784a6d2f233d1', + 'cgi/admin/Links/Utils.pm' => 'a624b2c55f1296cefe0111ac935d577c', + 'cgi/admin/Links/mod_perl.pm' => '0091238580c674bdfd932f466f6cae7b', + 'cgi/admin/admin.cgi' => '6bf02bebbd10774b4749f703bfc3fc3b', + 'cgi/admin/bases.pm' => '9f109037361a85d8d96d7938d9d72b88', + 'cgi/admin/constants.pm' => 'd03069c12befc4743e5927c96891d0cd', + 'cgi/admin/cron/expiry_notify.pl' => '448e88010364857966b6b57b85117f7e', + 'cgi/admin/mysqlman/MySQLMan.pm' => 'ecd443c5fd7b1726e14e8dc40c79bc5f', + 'cgi/admin/mysqlman/mysql.cgi' => 'bba224d2efc94cf6dfa3f6c8b1acd3aa', + 'cgi/admin/mysqlman/templates/alter_col.html' => 'e603165c406c5abfbb4f90381f8a71e5', + 'cgi/admin/mysqlman/templates/confirm.html' => 'c1badd1cbf4e8a3b79938df0b0a641af', + 'cgi/admin/mysqlman/templates/create_table.html' => 'c28f3e239d980a10f550248e5fe98058', + 'cgi/admin/mysqlman/templates/database.html' => 'd6b259696f6e588a5c6552208f637b84', + 'cgi/admin/mysqlman/templates/demo_prompt.html' => '279542121db9f9b7f4af80e7fd848b1b', + 'cgi/admin/mysqlman/templates/edit.html' => '9d96904094e0f5ae754ff580f90680d1', + 'cgi/admin/mysqlman/templates/help_add_col.html' => 'e6e38c7f78083abb135df0e1fc7acdea', + 'cgi/admin/mysqlman/templates/help_browse.html' => '03ccd5783bd14a1032b342ba36cefb8d', + 'cgi/admin/mysqlman/templates/help_col_def.html' => '38eff8f6dccd0fb4cdeb4a90b505b998', + 'cgi/admin/mysqlman/templates/help_col_def_change.html' => '41dcfd75f3f76bae12639ad69f1dcfc7', + 'cgi/admin/mysqlman/templates/help_confirm.html' => '6069217e46b3c7e63005b1f533ee1762', + 'cgi/admin/mysqlman/templates/help_create_db.html' => 'ba2e55016c3d5e5eba186dc843caf8da', + 'cgi/admin/mysqlman/templates/help_create_table.html' => 'a855b24e7889135361f241deeba8806c', + 'cgi/admin/mysqlman/templates/help_db_list.html' => '33e081caf1652e6c91466430d85b2659', + 'cgi/admin/mysqlman/templates/help_demo.html' => 'f09a37b4330102447c21688ef393f426', + 'cgi/admin/mysqlman/templates/help_edit.html' => '552ece9e6f52ef4cc7604ae4aac990d8', + 'cgi/admin/mysqlman/templates/help_export.html' => 'c94efc5fbbe55fff11bbcd53cdfdad38', + 'cgi/admin/mysqlman/templates/help_home.html' => '13f67665094fa327ca9cb6f67d9f22eb', + 'cgi/admin/mysqlman/templates/help_import.html' => '72b2142ef38b041b5e8c76722ac31aad', + 'cgi/admin/mysqlman/templates/help_insert.html' => 'b34e6e6c52f6c95b5e98dac327cbb51e', + 'cgi/admin/mysqlman/templates/help_login.html' => '55aa76ff7554074b3a354a2326f969a6', + 'cgi/admin/mysqlman/templates/help_login_back.html' => '2c30c012e4a62f9a7da06f24c845f3e7', + 'cgi/admin/mysqlman/templates/help_login_dbname.html' => '8025f11b2db873caea4e54be66cd8638', + 'cgi/admin/mysqlman/templates/help_logout.html' => '5c396cbe8fa9c239f6147ceccab4f966', + 'cgi/admin/mysqlman/templates/help_properties.html' => 'e1c6172cc83a35b22dea79f7da9d9296', + 'cgi/admin/mysqlman/templates/help_rename.html' => 'e801e6f86382257210a18059958398d0', + 'cgi/admin/mysqlman/templates/help_save_search_result.html' => 'e155cc5ff40f719c9555a746fae9c74e', + 'cgi/admin/mysqlman/templates/help_select.html' => '7d91865c36e3ac3632fc083ad5a6420b', + 'cgi/admin/mysqlman/templates/help_sql_dump.html' => 'da0bcc17d42864581b9b1b318aa57311', + 'cgi/admin/mysqlman/templates/help_sql_monitor.html' => 'f82675e6416d88d742aa571ce6a75a8a', + 'cgi/admin/mysqlman/templates/help_sqlerr.html' => '4ac82568fd269f9348198656a3c6f8b0', + 'cgi/admin/mysqlman/templates/help_table_list.html' => '9ec4842f6778c19202168b051e347a59', + 'cgi/admin/mysqlman/templates/help_toolbar.html' => 'f7663bc43d941b091b2e404516b37ddd', + 'cgi/admin/mysqlman/templates/insert.html' => 'd74d9a2258ddecee0c7e202f2ea61d64', + 'cgi/admin/mysqlman/templates/insert_fields.html' => '4e1b5ff4c845c237eb878978e53e5953', + 'cgi/admin/mysqlman/templates/login.html' => '6d13d98fe2b659a54ae096bfdb272d57', + 'cgi/admin/mysqlman/templates/login_back.html' => 'd461e4100d2ca18cbabb2ea054c0b69f', + 'cgi/admin/mysqlman/templates/login_dbname.html' => '092c2e81f37db629febbe81cca7c62f2', + 'cgi/admin/mysqlman/templates/logout.html' => '0346dc15c14c11914ba62abd7f6f2640', + 'cgi/admin/mysqlman/templates/op_add_fields.html' => 'e6c8f751ba34224d22eaf10bcd03c947', + 'cgi/admin/mysqlman/templates/op_create_db.html' => '13dffea3e703d6b7f0fe041b29cbe7cf', + 'cgi/admin/mysqlman/templates/op_create_table.html' => '7368affa370e480b9596f7fc9efdad14', + 'cgi/admin/mysqlman/templates/op_export.html' => 'c425e4fb55c23f68c415a2285a3049cb', + 'cgi/admin/mysqlman/templates/op_import.html' => '4c470bed4a3aedc72a9f44db5f3bc147', + 'cgi/admin/mysqlman/templates/op_mysqldump.html' => '719cbe5a8b62e95c2e2fe2589214c17c', + 'cgi/admin/mysqlman/templates/op_rename_table.html' => '482e17926735b9ad8bea7e104870396d', + 'cgi/admin/mysqlman/templates/op_sql_monitor.html' => 'f05b785829e9fb8cfca50b1ccad8d123', + 'cgi/admin/mysqlman/templates/property.html' => '0a59b3dad6c3cda02d12ab4d5b004818', + 'cgi/admin/mysqlman/templates/save_search.html' => '487977e323f17b8a06ee417d1399c7ce', + 'cgi/admin/mysqlman/templates/show_query.html' => 'f9e88a6cccc19eb73c1777ff5a9350de', + 'cgi/admin/mysqlman/templates/sqlerr.html' => 'fd83848afe0b0f36c63a22b80b7d40be', + 'cgi/admin/mysqlman/templates/table.html' => '45390df999187b59393bd12b57114f25', + 'cgi/admin/mysqlman/templates/table_browse.html' => 'acdc694460f5a6e32da550cf0ea91d01', + 'cgi/admin/mysqlman/templates/table_select.html' => '23be7cc16e3dbbcd8ab464ed691fbefd', + 'cgi/admin/nph-build.cgi' => '568405041a4220811896f12ff355ed04', + 'cgi/admin/nph-email.cgi' => 'fbd0950387d34ace168470dc08e5b077', + 'cgi/admin/nph-import.cgi' => 'e90369f883b885a812dc433e67b946fc', + 'cgi/admin/nph-index.cgi' => '16587c06a92bd4330b947e4112a18060', + 'cgi/admin/nph-verify.cgi' => '5c97042f1eb1ede1098d0f27d9e3f317', + 'cgi/admin/setup.cgi' => '1d47a63c0e550872e758a8cb54d995a0', + 'cgi/admin/templates/admin/3.0.0-3.0.1.css.diff.html' => 'dc2fcc0d3e809da9f9cde3d054039f96', + 'cgi/admin/templates/admin/3.0.0-3.0.1.diff.html' => '9e157a18680fabb7e2e3c2a1bf5f8957', + 'cgi/admin/templates/admin/3.0.1-3.0.2.css.diff.html' => 'a262d9e6e7b6bcb7e91ba8d5877473a4', + 'cgi/admin/templates/admin/3.0.1-3.0.2.diff.html' => '1145c31c2ce942fc53320ad04d119c8c', + 'cgi/admin/templates/admin/3.0.2-3.0.3.diff.html' => 'f10f63837879526df0e235766ee900da', + 'cgi/admin/templates/admin/3.0.3-3.0.4.diff.html' => '9c406df512bf25e333d181b248b7b411', + 'cgi/admin/templates/admin/3.0.4-3.1.0.css.diff.html' => '6cc63ce7d77bd1e248eb81286a7f76d5', + 'cgi/admin/templates/admin/3.0.4-3.1.0.diff.html' => '8fe291705713dd84774f45f4d2040bc2', + 'cgi/admin/templates/admin/3.1.0-3.2.0.css.diff.html' => '34f7833a626ad79c45f5a739f04f6be5', + 'cgi/admin/templates/admin/3.1.0-3.2.0.diff.html' => 'd4e1cce5ef019dcd301514c713c5f11c', + 'cgi/admin/templates/admin/3.2.0-3.3.0.css.diff.html' => '25991bdc69967108753711b47a46e2cb', + 'cgi/admin/templates/admin/3.2.0-3.3.0.diff.html' => 'c1d43667805019b069c575a0742219c8', + 'cgi/admin/templates/admin/build.html' => '0a1ae4956ed5623a447d5213a32ac551', + 'cgi/admin/templates/admin/build_css.html' => '1d6fd89de7a109bad445bec737be8979', + 'cgi/admin/templates/admin/build_email.html' => '6aed7a3e33cb4f23f5e69a56339bbb2b', + 'cgi/admin/templates/admin/build_global.html' => 'a2df9179a4df941771518c81eb28bdef', + 'cgi/admin/templates/admin/build_help.html' => '7962945df4e376baa7c54754ec07be85', + 'cgi/admin/templates/admin/build_lang.html' => 'f860196448a65fca06d80484f73ebefb', + 'cgi/admin/templates/admin/build_nav.html' => 'ac0228604b22405f3f26c7793fc38175', + 'cgi/admin/templates/admin/build_tpl.html' => '8bcca2bf222cf2fee4c52849585139d7', + 'cgi/admin/templates/admin/copyright.html' => 'fcc5f4b351a302e2e4ae93e5f0bf9898', + 'cgi/admin/templates/admin/db.html' => '249a2f9d6003528c09fa8993c13851f1', + 'cgi/admin/templates/admin/db_help.html' => '0b72a6bbd00d5e5ec44299f3bc03f87e', + 'cgi/admin/templates/admin/db_nav.html' => 'ef51f46e7648f0c43c8958e1537a7930', + 'cgi/admin/templates/admin/email_confirm_cancel_mailing.html' => '703225d5f187ea3e41f7a33e77777e3f', + 'cgi/admin/templates/admin/email_confirm_delete_all_mailings.html' => 'f511b6f794284e6290413ee64a3cbf97', + 'cgi/admin/templates/admin/email_confirm_delete_finished_mailings.html' => 'f1670a4a4fa44d67ed3bf568736876cd', + 'cgi/admin/templates/admin/email_contents.html' => 'a6c9293a5ec223cab8e2adf68c12877d', + 'cgi/admin/templates/admin/email_default.html' => '661121adfb215554bb107b677bb56863', + 'cgi/admin/templates/admin/email_error.html' => '1e9f53d66c06ad91df7beb854628c76e', + 'cgi/admin/templates/admin/email_everyone.html' => '91cb808fec7651f5629ffb94b86b5366', + 'cgi/admin/templates/admin/email_frames.html' => '9d105a1c1ea766d189503d62dcffbe58', + 'cgi/admin/templates/admin/email_link_owners.html' => 'b2e94a87aa1592e03d8124d32ccf3b27', + 'cgi/admin/templates/admin/email_list.html' => '390de051ff4280733b90da1bc8ee31e9', + 'cgi/admin/templates/admin/email_list_add.html' => 'df15e4e62eeac2095aff28347a29f937', + 'cgi/admin/templates/admin/email_list_added.html' => '55fce8ac24b3cd6b7602065f7714aac6', + 'cgi/admin/templates/admin/email_list_delete.html' => '688057b611487e4baee966788cdcb2f6', + 'cgi/admin/templates/admin/email_list_delete_list.html' => 'e33d4f3ef62064ed3a878f7e55440c37', + 'cgi/admin/templates/admin/email_list_list.html' => '05667e7353aba37bb660ba57f852ede5', + 'cgi/admin/templates/admin/email_list_mail.html' => '57caac41bef186319d551da6743b4625', + 'cgi/admin/templates/admin/email_list_mail_list.html' => '2226b45e5d2ca201230d1de64db032e4', + 'cgi/admin/templates/admin/email_list_moded.html' => 'e46f3ecefc1c8dd043defc93f34bd573', + 'cgi/admin/templates/admin/email_list_modify.html' => '89ef4b0dba3b11beea50c06340a98e2b', + 'cgi/admin/templates/admin/email_list_modify_list.html' => '9e569f2f67afab48ed3ebda9bc8d6fa0', + 'cgi/admin/templates/admin/email_list_of_lists.html' => '771018a7a2a5a7cd279c843b0cb8a964', + 'cgi/admin/templates/admin/email_mailing_detail.html' => '282eb6cd00ebd645daca042e5aed1f03', + 'cgi/admin/templates/admin/email_mailings.html' => '03c8df7bde561e7b53d46f25bc85c6e8', + 'cgi/admin/templates/admin/email_newsletter.html' => '4552cda30cfdb7dd121d58193a34c292', + 'cgi/admin/templates/admin/email_newsletter_browse.html' => '613c172557063648daa5a9fce7ade283', + 'cgi/admin/templates/admin/email_newsletter_edit_template.html' => '1237e13135e01a1bf57b476ab6c57fd7', + 'cgi/admin/templates/admin/email_newsletter_subscribers.html' => '3cdd24ccbcb4163ccb87282d082cec28', + 'cgi/admin/templates/admin/email_newtemp_save_as.html' => 'c2d216eb47b5b347335057b898732957', + 'cgi/admin/templates/admin/email_selected_links.html' => 'd355433cf732729c4dce3c42bc31816c', + 'cgi/admin/templates/admin/email_selected_links_mail.html' => '44bd1e98e2b767d4b4483a9da69b459f', + 'cgi/admin/templates/admin/email_selected_users.html' => '2e7f9648a644bb0400b1b980cc127614', + 'cgi/admin/templates/admin/email_selected_users_mail.html' => '76d515d061aafabda048c867d2f10ab0', + 'cgi/admin/templates/admin/error.html' => '5dd8d268027df72f58067dc428711683', + 'cgi/admin/templates/admin/fileman/common/help.html' => '4fa82f5faaeabb9763ebbd2be15da514', + 'cgi/admin/templates/admin/fileman/common/help_chmod.html' => '1eb2ccd7f099c4502a2c74abb236dfdc', + 'cgi/admin/templates/admin/fileman/common/help_command.html' => 'f84a922de3449cd811f13fce8e638a93', + 'cgi/admin/templates/admin/fileman/common/help_compress.html' => '582a5eb74b9526232ef9ff6520af3350', + 'cgi/admin/templates/admin/fileman/common/help_copy.html' => '52ec9e153b713dbc2a5aa3323c5a1023', + 'cgi/admin/templates/admin/fileman/common/help_diff.html' => 'c137e8d14e4df8d1847e75488ad1adf5', + 'cgi/admin/templates/admin/fileman/common/help_download.html' => '4c4a03bf0c8eec03ae7f3f257e1e1cec', + 'cgi/admin/templates/admin/fileman/common/help_file.html' => '155b83fee7c21441af47957b5663d0f7', + 'cgi/admin/templates/admin/fileman/common/help_logs.html' => '7adcea2fd4f4ef64027f4003a27b9c37', + 'cgi/admin/templates/admin/fileman/common/help_makedir.html' => '533c8592b80cf55a381a99766106c2e3', + 'cgi/admin/templates/admin/fileman/common/help_move.html' => '19249e687645ae06dd35782315cf5859', + 'cgi/admin/templates/admin/fileman/common/help_password.html' => '13443c14ebb0d4bbf1429de5e96561b3', + 'cgi/admin/templates/admin/fileman/common/help_perl.html' => 'a12853c37a6e0905cedad028bf8b806e', + 'cgi/admin/templates/admin/fileman/common/help_preferences.html' => 'be7c93fd4198574d7713d1a3a8f94c85', + 'cgi/admin/templates/admin/fileman/common/help_protect.html' => '44ab16274b413ed0a66e3bdd7a910ebc', + 'cgi/admin/templates/admin/fileman/common/help_rename.html' => '37984624f2b1a9e108514c6a9b9ad388', + 'cgi/admin/templates/admin/fileman/common/help_replace.html' => 'af68a1911242befacc86ae7ecf74c3a2', + 'cgi/admin/templates/admin/fileman/common/help_search.html' => 'a205dd94fe3968ca517c095089348466', + 'cgi/admin/templates/admin/fileman/common/help_setup.html' => '6f55b679e1b11a7390a97d2fdf5d6773', + 'cgi/admin/templates/admin/fileman/common/help_symlink.html' => 'd63a9c49dab84529bb9b0d360aa248e4', + 'cgi/admin/templates/admin/fileman/common/help_tail.html' => '617956df49018fb3f69a3c28780614f0', + 'cgi/admin/templates/admin/fileman/common/help_uncompress.html' => '9bd19ff4eb59ff111ac2265cc1c04935', + 'cgi/admin/templates/admin/fileman/common/help_upload.html' => '546c8a8d0400dd1e7ee2b6ba703fec16', + 'cgi/admin/templates/admin/fileman/common/help_user.html' => 'ea61ce0036181b9567847f34ccf9e1b3', + 'cgi/admin/templates/admin/fileman/luna/compressed.html' => 'ca3c9b60d0d4c6cc93b568b129d0db4c', + 'cgi/admin/templates/admin/fileman/luna/editor.html' => '43d443171b443b0b392c59babadc429c', + 'cgi/admin/templates/admin/fileman/luna/env.html' => '3f9b48114695ce2c0c1ac281c3db0d09', + 'cgi/admin/templates/admin/fileman/luna/home.html' => 'cdbe52cb9ca60ef903a74737dcb1db7e', + 'cgi/admin/templates/admin/fileman/luna/include_common_head.html' => '00ffece52314eb631e7cf85f8141d06c', + 'cgi/admin/templates/admin/fileman/luna/include_footer.html' => 'ef9380132ad3204abb74915895fceb00', + 'cgi/admin/templates/admin/fileman/luna/include_header.html' => 'e7c491a46129771af72733d475eef7fa', + 'cgi/admin/templates/admin/fileman/luna/include_user_form.html' => 'c95de9d74c13dbb941ae3e14bb05db83', + 'cgi/admin/templates/admin/fileman/luna/include_user_permission.html' => '71a5ff1a15519789432579e0585bb2a5', + 'cgi/admin/templates/admin/fileman/luna/log.html' => '15807d7d4f83ab60d9c4573f9da78e8b', + 'cgi/admin/templates/admin/fileman/luna/log_search.html' => '608da94d700d702c52d7625beae23e0e', + 'cgi/admin/templates/admin/fileman/luna/login.html' => '908120b5827de980b034c298171f8186', + 'cgi/admin/templates/admin/fileman/luna/main.html' => '60ba26e594c66f5c920df357582d38dc', + 'cgi/admin/templates/admin/fileman/luna/password.html' => '81fd4f9b87fde4b6f11bee25b1f912d1', + 'cgi/admin/templates/admin/fileman/luna/preferences.html' => '8d1ff8b2699130e0ea3caa59b626a482', + 'cgi/admin/templates/admin/fileman/luna/reset_password.html' => '727e1edb0b4b18fe40011f2cb2c92bc4', + 'cgi/admin/templates/admin/fileman/luna/search.html' => '409de0f57e46f50ccf30115cfea2cf44', + 'cgi/admin/templates/admin/fileman/luna/setup.html' => 'cc99859f55e29a206825c835da3a91ff', + 'cgi/admin/templates/admin/fileman/luna/user.html' => '70b42927a3493c943c12f2e1e97beedd', + 'cgi/admin/templates/admin/fileman/luna/user_form.html' => 'b9d2bd6e442f412d66b895efd47706e0', + 'cgi/admin/templates/admin/help.html' => '1b9c2a0dc39b778085dba4c109f882b7', + 'cgi/admin/templates/admin/help/GT/AutoLoader.html' => 'fbd5cbcf3065e7976283d1feb2b54a10', + 'cgi/admin/templates/admin/help/GT/Base.html' => 'c902ec36273df7cfd636003ad3024224', + 'cgi/admin/templates/admin/help/GT/CGI.html' => '50acc6cdd3bbc897a4ff859b181ce4e1', + 'cgi/admin/templates/admin/help/GT/Cache.html' => '7bb8957ddad6b2acd3d232f27948fcd2', + 'cgi/admin/templates/admin/help/GT/Config.html' => '32c74dd4d013f570c804c89aaf2517f3', + 'cgi/admin/templates/admin/help/GT/Date.html' => '8097ff761aab7ec6871078bd26fddfa1', + 'cgi/admin/templates/admin/help/GT/Delay.html' => '159e490524d2985911fd921a59e301e3', + 'cgi/admin/templates/admin/help/GT/Dumper.html' => 'b810bae81679ae6467c61e31252bcb87', + 'cgi/admin/templates/admin/help/GT/File/Diff.html' => '8224ae3402153f4c864a3652fe935456', + 'cgi/admin/templates/admin/help/GT/File/Tools.html' => '51fb0f63a9747382e5ee1228a016a58e', + 'cgi/admin/templates/admin/help/GT/IPC/Filter.html' => '68aca76c97c233f40012cac22a3b53d6', + 'cgi/admin/templates/admin/help/GT/IPC/Filter/Block.html' => 'f0e014fd5bf9f4ec91f4fe0ab3efc410', + 'cgi/admin/templates/admin/help/GT/IPC/Filter/Line.html' => '3f24eda535d693eabd7e07128ff6b6a7', + 'cgi/admin/templates/admin/help/GT/IPC/Filter/Stream.html' => '02ced424db0074591862e44d97f066a2', + 'cgi/admin/templates/admin/help/GT/IPC/Run.html' => '27de9fc109231984d7ddbe4eb6e2ebad', + 'cgi/admin/templates/admin/help/GT/IPCountry.html' => '61024fc7167e0977f4cd1baba43b10c4', + 'cgi/admin/templates/admin/help/GT/Image/Security.html' => '5ba44e861de4781f2ac3e6ed7c6936e7', + 'cgi/admin/templates/admin/help/GT/Image/Size.html' => '91e4061548bf761718df8e486017d487', + 'cgi/admin/templates/admin/help/GT/Installer.html' => 'db97c3fbc41500bde8a0f9989e7e4212', + 'cgi/admin/templates/admin/help/GT/JSON.html' => 'e2b5999c87136da78c858d9d5cf65aed', + 'cgi/admin/templates/admin/help/GT/JSON/PP.html' => 'd2450ee799dba5f25da5c9e8e0f07cda', + 'cgi/admin/templates/admin/help/GT/JSON/PP/Boolean.html' => 'ba5554017628fa1bab1c71d1f3bab8fc', + 'cgi/admin/templates/admin/help/GT/JSON/PP5005.html' => 'c8fd4a75a4a682d8873607c20286876e', + 'cgi/admin/templates/admin/help/GT/JSON/PP56.html' => '9c21166fa035cdb194043629ff0e7932', + 'cgi/admin/templates/admin/help/GT/JSON/PP58.html' => '064bb59085a564026eea93d4e91cb1e8', + 'cgi/admin/templates/admin/help/GT/Lock.html' => '21b8a5e634845acaf5db5d4c2fd8a06e', + 'cgi/admin/templates/admin/help/GT/MD5.html' => 'a505dc329561fef9a1da0fa67c7325a9', + 'cgi/admin/templates/admin/help/GT/MD5/Crypt.html' => '81005f016cfcae6ed52e22b35e423d25', + 'cgi/admin/templates/admin/help/GT/MIMETypes.html' => '2827d8c06a12fc527ef4a5a06fa31f43', + 'cgi/admin/templates/admin/help/GT/Mail.html' => 'bf0c8422f8e4207f93c88e5472ba6e99', + 'cgi/admin/templates/admin/help/GT/Mail/BulkMail.html' => '22ef1a5ef33f4e95e394e1f3098d9f67', + 'cgi/admin/templates/admin/help/GT/Mail/Editor.html' => '52a646719f1cc2a794b511a52a5b9809', + 'cgi/admin/templates/admin/help/GT/Mail/Encoder.html' => '16120bcce3b2aec1db4ee2e649a09c56', + 'cgi/admin/templates/admin/help/GT/Mail/POP3.html' => 'fc84560ac4d01ab501897b742befd5e9', + 'cgi/admin/templates/admin/help/GT/Mail/Parse.html' => '70b8645a9112dda7acd7b6f259a08984', + 'cgi/admin/templates/admin/help/GT/Mail/Parts.html' => '5b855671b9073ce421b8939dd67c054e', + 'cgi/admin/templates/admin/help/GT/Mail/Send.html' => '4c67c4bb2285d80feade550fe00710e9', + 'cgi/admin/templates/admin/help/GT/Payment/Remote/2CheckOut.html' => 'afa8d72edeaff1e68653bdda9ca05a27', + 'cgi/admin/templates/admin/help/GT/Payment/Remote/PayPal.html' => '313c2050f4135072fa47967d0957ab2c', + 'cgi/admin/templates/admin/help/GT/Payment/Remote/WorldPay.html' => '892ad4f40be22f3b5fa74fdd5c1ebe1a', + 'cgi/admin/templates/admin/help/GT/Plugins.html' => '61c158c5d6bbbc6179eafc937f8db068', + 'cgi/admin/templates/admin/help/GT/Plugins/Installer.html' => '4fbfcf3498e1eefeb076484b0e74a168', + 'cgi/admin/templates/admin/help/GT/SQL.html' => 'b624dadb0e7cba528dfef07ac27d8163', + 'cgi/admin/templates/admin/help/GT/SQL/Admin.html' => 'a17e702241219c4e90af9697afac21c7', + 'cgi/admin/templates/admin/help/GT/SQL/Condition.html' => 'a536b06fca4fdb0792e171630fa6a54c', + 'cgi/admin/templates/admin/help/GT/SQL/Creator.html' => '3ac21cd0eaac5ded5445e93580f956c3', + 'cgi/admin/templates/admin/help/GT/SQL/Editor.html' => 'b7e5b378b8bad4d51d688ec11f78e8ca', + 'cgi/admin/templates/admin/help/GT/SQL/File.html' => 'e8e80daadd7a8129ba19f13e02c1b21f', + 'cgi/admin/templates/admin/help/GT/SQL/Relation.html' => '849f8d83e826374806eb233b77f6944f', + 'cgi/admin/templates/admin/help/GT/SQL/Search.html' => 'e16447c00764fe4aec6ce922e0dcf0b0', + 'cgi/admin/templates/admin/help/GT/SQL/Table.html' => 'bd98d79a347f688109626facf5752a6f', + 'cgi/admin/templates/admin/help/GT/SQL/Tree.html' => '2412483307fc167a672cebc1f1b7e89b', + 'cgi/admin/templates/admin/help/GT/SQL/Tree/Rebuild.html' => 'bf3c53a90ec15c3fb59573e80e4abe46', + 'cgi/admin/templates/admin/help/GT/SQL/Types.html' => '97a647aacb0d60489d814c4d061da31a', + 'cgi/admin/templates/admin/help/GT/Session/File.html' => 'daa1282bbd9c02966cd9509edd2144ec', + 'cgi/admin/templates/admin/help/GT/Session/TempTable.html' => 'c5cc7f35b4c004591724159799a0fb67', + 'cgi/admin/templates/admin/help/GT/Socket.html' => '368da60e16134e1a576977c240caa5c0', + 'cgi/admin/templates/admin/help/GT/Socket/Client.html' => 'e4f7ad83d9cfcaa42952a9c5aecd20db', + 'cgi/admin/templates/admin/help/GT/Tar.html' => '3e732b221b8a0142f7f4c098126a1adc', + 'cgi/admin/templates/admin/help/GT/TempFile.html' => 'b2207ac55fe03c9ebb73ac5d23a1196e', + 'cgi/admin/templates/admin/help/GT/Template.html' => '07fe9dea64c084f0d9a5764dc29484f2', + 'cgi/admin/templates/admin/help/GT/Template/Editor.html' => 'a7db42f9f73c17b6f3499ad6bae6e9f1', + 'cgi/admin/templates/admin/help/GT/Template/Inheritance.html' => '8f0cef3d77c0eb0112c73e7646250cef', + 'cgi/admin/templates/admin/help/GT/Template/Tutorial.html' => 'eaaf1d7e119b7310622e346623bea292', + 'cgi/admin/templates/admin/help/GT/Template/Vars.html' => '628af5a306d00d6fb2c44802e706ce4c', + 'cgi/admin/templates/admin/help/GT/URI.html' => 'cf54ee94200908cbc064265c104ea95b', + 'cgi/admin/templates/admin/help/GT/URI/HTTP.html' => '2fcb3840ab341456db60baf2d79796eb', + 'cgi/admin/templates/admin/help/GT/URI/HTTPS.html' => 'cdf405f384967eb1d1bc2aaebdda3e30', + 'cgi/admin/templates/admin/help/GT/WWW.html' => '75f3629880f054009491cfcd15e31bee', + 'cgi/admin/templates/admin/help/GT/WWW/http.html' => 'b025d4fabd8fff5dcab69a3b2af52247', + 'cgi/admin/templates/admin/help/GT/WWW/http/Header.html' => 'e619be0eaab104fca66ef4e0398db793', + 'cgi/admin/templates/admin/help/GT/WWW/http/Response.html' => '28db64bb4e3a603c1dcc87c9aaece7e7', + 'cgi/admin/templates/admin/help/GT/WWW/https.html' => '3af79ab08b53c2d78d12a3a3c10b2350', + 'cgi/admin/templates/admin/help/help_admin.html' => '613734b7b7dd0dcb15f3c3620ed1bda8', + 'cgi/admin/templates/admin/help/help_browse.html' => '3d7fe7a52c61068027472b34e11046e9', + 'cgi/admin/templates/admin/help/help_build.html' => 'dc38507af01db7a6f43cc78ae003110d', + 'cgi/admin/templates/admin/help/help_database.html' => '71823d4076901d49ea2d10c760a8b8aa', + 'cgi/admin/templates/admin/help/help_editors.html' => 'b28d4d179481874a981b48a114dd8f1a', + 'cgi/admin/templates/admin/help/help_email.html' => 'b5ed697c8587a512da7c1bb155284238', + 'cgi/admin/templates/admin/help/help_guide.html' => '7c49b7ca767886dcc352499f4a79faf0', + 'cgi/admin/templates/admin/help/help_guide_enhance.html' => 'b753386607f28dec24bd5ce38e4f5542', + 'cgi/admin/templates/admin/help/help_guide_hooks.html' => '4bc7414b5aae6d31e3a40fa45af4bbf1', + 'cgi/admin/templates/admin/help/help_guide_libs.html' => '4cf50070c3e72755e25392fa9c368bcb', + 'cgi/admin/templates/admin/help/help_guide_libs_top.html' => '80d29800bdb1bef4557e7ae7ba334136', + 'cgi/admin/templates/admin/help/help_guide_links_core.html' => '8685a0a17c2ca28d88a2781f5f79e62d', + 'cgi/admin/templates/admin/help/help_guide_links_db.html' => '76a62bff4f3683eaab7a6aa86b1ac8f8', + 'cgi/admin/templates/admin/help/help_guide_modperl.html' => '9e94ea852f932d08b42bf777137653b4', + 'cgi/admin/templates/admin/help/help_guide_plugins.html' => 'e755064ba7f0125f0407c4d04ab04584', + 'cgi/admin/templates/admin/help/help_guide_plugins_install.html' => '8c81046a2463fc88d21461f50c70fdf0', + 'cgi/admin/templates/admin/help/help_guide_ref.html' => 'a4c1b244de95a101cedb576bbe6ab07c', + 'cgi/admin/templates/admin/help/help_guide_sample.html' => '8e636e4910423b6bbf4c6a1189e664ca', + 'cgi/admin/templates/admin/help/help_payments.html' => '052a2f79a1c35cca63dc6a55ee316299', + 'cgi/admin/templates/admin/help/help_plugin_ref.html' => '11d993501835d2ff97efebd39cd8edf8', + 'cgi/admin/templates/admin/help/help_plugins.html' => '74a2f68211f5830308539b160e03d5d8', + 'cgi/admin/templates/admin/help/help_support.html' => '1173d4496a0014f45a0921dc6dc609a6', + 'cgi/admin/templates/admin/help/help_templates.html' => '3796bf102766f90593c384a47f2b9ba5', + 'cgi/admin/templates/admin/help/help_templates_syntax.html' => 'a53fd271e930b829a2ac4ca3ea049ff7', + 'cgi/admin/templates/admin/help/help_templates_tags.html' => 'b3817f0638dbf62998f448abb51d71ad', + 'cgi/admin/templates/admin/help/help_toc.html' => 'e4fb155267c46c7023e5398c3930387a', + 'cgi/admin/templates/admin/help/index.html' => '842594a9282a8a65bbbf3e2e7d8442da', + 'cgi/admin/templates/admin/help/index_nav.html' => '6bd2e2921abe1e2f0619d9c9f4b7bdbf', + 'cgi/admin/templates/admin/help_body.html' => 'd9a6499a9d392f1a178aa8bd32e6da27', + 'cgi/admin/templates/admin/help_nav.html' => '5355085c535a66f93f3a3f1aeb514d98', + 'cgi/admin/templates/admin/home.html' => 'a99aeaa14b78622f5e2b1d7cd78b1ba6', + 'cgi/admin/templates/admin/home_body.html' => '9eefe8105747500f8504254199a4670b', + 'cgi/admin/templates/admin/home_left.html' => 'a0d17fc4b878726456f636da71051a0e', + 'cgi/admin/templates/admin/home_nav.html' => 'cc28014cfa55a94c871ef12d230dd72b', + 'cgi/admin/templates/admin/home_right.html' => '37e7599bf6ede9bd61261f6828267585', + 'cgi/admin/templates/admin/include_header.html' => '5a8aa98a84124cf841f0125ee19446d2', + 'cgi/admin/templates/admin/include_style.html' => '2a16c81f51455a2b563f7273fb9dd5d7', + 'cgi/admin/templates/admin/include_update_checker.html' => '86cbc0b050040abe5321b5f622850fea', + 'cgi/admin/templates/admin/payment.html' => '510d6eb121887c59f82f86f3c217592a', + 'cgi/admin/templates/admin/payment_cat_price.html' => 'b2b0ccf65441259bda6fd450fdba3939', + 'cgi/admin/templates/admin/payment_details.html' => 'f426568166d13d40850f937cea025c41', + 'cgi/admin/templates/admin/payment_header.html' => '673284bdfea6f1f840ccb4bd2619216c', + 'cgi/admin/templates/admin/payment_log.html' => '4ca2c030f1fcc85a6cfa56063824f454', + 'cgi/admin/templates/admin/payment_methods_add.html' => '6737248bb13301500505dfdd5357e2d2', + 'cgi/admin/templates/admin/payment_methods_add_method.html' => 'fbff4969028e1627fa37cd623290e5d8', + 'cgi/admin/templates/admin/payment_methods_add_method_submit.html' => '71c17a95ae6880167a3deb05412c4118', + 'cgi/admin/templates/admin/payment_methods_display_existing.html' => '01f3d201563c1ba221760925a4fb79fb', + 'cgi/admin/templates/admin/payment_methods_display_new.html' => 'f08f672faf2cf947fb7a9aa4758e3b78', + 'cgi/admin/templates/admin/payment_methods_list.html' => '9bfdbf694dab03a1cdc63258797ffbea', + 'cgi/admin/templates/admin/payment_methods_remove.html' => 'b17befbc415ed476c7065867eca66f60', + 'cgi/admin/templates/admin/payment_nav.html' => 'dc6221e574a6ab6c2b916d8ed7dd2db9', + 'cgi/admin/templates/admin/payment_overview.html' => 'b7a41f058e394b070e8296a8b7aad097', + 'cgi/admin/templates/admin/payment_setup.html' => 'dd81415e047feaa220c275cc66a66579', + 'cgi/admin/templates/admin/plugin.html' => 'c051c1cda8ab527e3775d37e19a0de3a', + 'cgi/admin/templates/admin/plugin_help.html' => 'ae3d90ef951d3ad2ed20c4f41bb3b767', + 'cgi/admin/templates/admin/plugin_manager.html' => '49bd1c5bd85d3a58388ba36109207992', + 'cgi/admin/templates/admin/plugin_manager_delete.html' => '2bec33d77af59a159ae7cf9bba5fe35e', + 'cgi/admin/templates/admin/plugin_manager_download.html' => '849fcd25999761a04309526efbef31a6', + 'cgi/admin/templates/admin/plugin_manager_edit.html' => '7477c41b5b375904b135caf86dbc972b', + 'cgi/admin/templates/admin/plugin_manager_edit_files.html' => 'a955809c5a5a6a9957019ed32bca7b3a', + 'cgi/admin/templates/admin/plugin_manager_list.html' => '79abb8b94ec5e85c50501875fc6cc4d8', + 'cgi/admin/templates/admin/plugin_manager_pre_install.html' => '4ccd629d164235d696000395754252ab', + 'cgi/admin/templates/admin/plugin_manager_pre_uninstall.html' => 'a1a85eeef058e89f629639873ccceecf', + 'cgi/admin/templates/admin/plugin_nav.html' => 'b4b8d03da711068baca2771bace30944', + 'cgi/admin/templates/admin/plugin_wizard.html' => '44fa7df489cf00b5fdb5f4fe5a179807', + 'cgi/admin/templates/admin/plugin_wizard_step1.html' => 'c7c41fd023b35e786f932d1ec05d1d45', + 'cgi/admin/templates/admin/plugin_wizard_step2.html' => '6263571d1b2357f57862fe45a22ce2c2', + 'cgi/admin/templates/admin/plugin_wizard_step3.html' => '1a8ca3cd13f929485d7c7c16e41a554b', + 'cgi/admin/templates/admin/plugin_wizard_step4.html' => 'b72a8e6218311b30525af04c014387d7', + 'cgi/admin/templates/admin/plugin_wizard_step5.html' => '8204ea138441d7e91ddb4b787e1d18db', + 'cgi/admin/templates/admin/plugin_wizard_step6.html' => 'aad8670caa6479835c247af05fbc6b18', + 'cgi/admin/templates/admin/plugin_wizard_step7.html' => '8cd79b02137e9b441074f55321e2b40d', + 'cgi/admin/templates/admin/plugin_wizard_step8.html' => '5be07bfa0cbcbe7513b6ae3daba67661', + 'cgi/admin/templates/admin/setup.html' => '2a635cc5167206bac3ce5fbf6f2a6aa4', + 'cgi/admin/templates/admin/setup_build.html' => '74413e718d40fec3d83819f0d4222377', + 'cgi/admin/templates/admin/setup_date.html' => '2fc42775a6d3a26da4ae2f5a08698124', + 'cgi/admin/templates/admin/setup_email.html' => 'db7799a36129d41dd17c876949729aee', + 'cgi/admin/templates/admin/setup_env.html' => 'a8d4eeac1e86f7a6d446645c15333242', + 'cgi/admin/templates/admin/setup_first.html' => 'ebb15f20d2e9d97554b14afb099a31f8', + 'cgi/admin/templates/admin/setup_help.html' => '68293f21da331aaa3a30cc73157cefc2', + 'cgi/admin/templates/admin/setup_misc.html' => '4c12c196232f2b0a346e2d17d75bd52f', + 'cgi/admin/templates/admin/setup_nav.html' => 'f50154ad1a293a8e869cfd62f08f3556', + 'cgi/admin/templates/admin/setup_pass.html' => '32894240fddb293403bee239d94d5af9', + 'cgi/admin/templates/admin/setup_path.html' => 'c50c7b2aa3d7b6946e93dff157b5cd8d', + 'cgi/admin/templates/admin/setup_reset.html' => 'e62ab1755fd981fba739bc45e057f9a4', + 'cgi/admin/templates/admin/setup_review.html' => '79f8105c4a94334a3c2a80dbe3bacaa8', + 'cgi/admin/templates/admin/setup_search.html' => '499ae2be2c29ee5b9efb1a431ad227ed', + 'cgi/admin/templates/admin/setup_second.html' => '1681a6047dbf4dad22a7b750b67fc050', + 'cgi/admin/templates/admin/setup_sql.html' => '238d79324305d9f67fa19c5fe7f5151f', + 'cgi/admin/templates/admin/setup_third.html' => '79a759b88d44bdb1696679877b6d2aef', + 'cgi/admin/templates/admin/setup_user.html' => '0c7cd04fb8be25f244065686eaaed169', + 'cgi/admin/templates/admin/tools_duplicate.html' => 'de1a752aebf2ea42e0b96373f47a17e7', + 'cgi/admin/templates/admin/tools_expired_purge.html' => 'b84b74e3ad8ce4fb343173708b12bbc5', + 'cgi/admin/templates/admin/tools_module_env.html' => 'b2936244859757998b1555bc86d75485', + 'cgi/admin/templates/admin/tools_mysqlman.html' => '936b3a54cc0f59301e286873be2bbaf3', + 'cgi/admin/templates/admin/tools_search_logs.html' => 'fb5ea495cf36b3333457c2de33c2a8bf', + 'cgi/admin/templates/admin/tools_sql_monitor.html' => 'ffac34ea3d5e3f06719ef877c6d2ad4c', + 'cgi/admin/templates/admin/tools_status.html' => 'd219429305475cca311e423a8eb2a5c8', + 'cgi/admin/templates/admin/tools_validate.html' => '86ad7201c99f881ef3ae688133f9371d', + 'cgi/admin/templates/admin/tools_validate_changes.html' => 'dfc15fa7331615377d5063b5602721e2', + 'cgi/admin/templates/admin/tools_validate_reviews.html' => '95afe1f6ee1a7e17e69c7eddf28a3865', + 'cgi/admin/templates/admin/tools_verify.html' => '05414292aa48563dcd9155e03abb91a8', + 'cgi/admin/templates/admin/tools_view_status.html' => 'caa9b564247c1e4228b558aee45c3628', + 'cgi/admin/templates/admin/update.html' => '0c57d3a3be44bbbd23f4f567d3fde61d', + 'cgi/admin/templates/admin/update_available.html' => '59d5ad267453bb349bc0e7044651f81b', + 'cgi/admin/templates/admin/update_cat_tree.html' => '1d36b7c3778d4878120a88c32a80991d', + 'cgi/admin/templates/admin/update_display.html' => 'd178c4087157278834f7abdf294d9d92', + 'cgi/admin/templates/admin/update_history.html' => 'bf37f50cb4b4eb6a0a6adffa11c4fbd0', + 'cgi/admin/templates/admin/update_install.html' => '195906f8be064e9499f7a1cf894c6571', + 'cgi/admin/templates/admin/update_js.html' => '6a253fe6d66fbd401bd2fcf42e70351e', + 'cgi/admin/templates/admin/update_list.html' => '732976b23ec74c5307070e33995a337d', + 'cgi/admin/templates/admin/update_nav.html' => 'feab85ca6ed107a795bc13c25a0845a1', + 'cgi/admin/templates/admin/update_rerun.html' => '78bfbbdd758e39928b48bf97b36f9bdf', + 'cgi/admin/templates/admin/update_style.html' => '385dfadef6ccbb8a7f37bed60ebf75ec', + 'cgi/admin/templates/admin/update_version.html' => 'b9f8f1646de5292426cac467479fc2ff', + 'cgi/admin/templates/browser/browser.html' => '80b1c524cfc54f5dab3124079ec74906', + 'cgi/admin/templates/browser/browser_category.html' => 'c9e883171851828b264bd04f93c06aa6', + 'cgi/admin/templates/browser/browser_category_add.html' => '50dc6497eac2b20208d0d47aa56348d4', + 'cgi/admin/templates/browser/browser_category_add_form.html' => 'b343f2e279f61fe3fc04c9bd41eb224d', + 'cgi/admin/templates/browser/browser_category_del.html' => 'bc57e5a8a9628b33ef266b40be436be4', + 'cgi/admin/templates/browser/browser_category_del_form.html' => '7fcc25c5bba68ced2fbdcc8081a83bb6', + 'cgi/admin/templates/browser/browser_category_editors_form.html' => '7f8bf6c8ee8d97b5f730ffcdbff899fe', + 'cgi/admin/templates/browser/browser_category_editors_row.html' => '6cae8cf08f0ec009e8073d762f9a1ed9', + 'cgi/admin/templates/browser/browser_category_expand.html' => '5338be85eb5400d3619c9cfdce7d5663', + 'cgi/admin/templates/browser/browser_category_modify.html' => 'da9a0e95a398f7a32711d60e796e83a8', + 'cgi/admin/templates/browser/browser_category_modify_form.html' => 'd5437e259e082e4acae41adb887bdb7d', + 'cgi/admin/templates/browser/browser_category_move.html' => 'c4465f1caaafaa8a02c9a3c6bf0695a9', + 'cgi/admin/templates/browser/browser_category_move_form.html' => '0604d9f68c3aaf2d42507fe8a556261c', + 'cgi/admin/templates/browser/browser_category_related_form.html' => 'c8363177005a3dfa30e1720caae01340', + 'cgi/admin/templates/browser/browser_code_init.html' => 'a5fc26c111d034bb8b9ece8e5a65554f', + 'cgi/admin/templates/browser/browser_info.html' => '5fc2a0421c9570cc315747630cb2947d', + 'cgi/admin/templates/browser/browser_javascript_error.html' => '3b24cf49f70c0254e6a8519f4713586f', + 'cgi/admin/templates/browser/browser_link_add.html' => 'd662bdf0fab30906538f28b35d3a7c34', + 'cgi/admin/templates/browser/browser_link_add_form.html' => 'fb06896013b3117dad1e7129c645c194', + 'cgi/admin/templates/browser/browser_link_copy.html' => '6c8fa8eb3ddc8e16dbf93c34c4ace0f1', + 'cgi/admin/templates/browser/browser_link_copy_form.html' => 'b75294ed7fa914c2e3331978172d02ed', + 'cgi/admin/templates/browser/browser_link_del.html' => '50fe65f957970f89e8d344a947e479c4', + 'cgi/admin/templates/browser/browser_link_del_form.html' => '5372652c7de9301f10748ae8301098df', + 'cgi/admin/templates/browser/browser_link_list.html' => 'fb19ca8661323d839d1faf44a5112ce5', + 'cgi/admin/templates/browser/browser_link_modify.html' => 'dd1fa3fc9d30fc6332357a4837e59ab9', + 'cgi/admin/templates/browser/browser_link_modify_form.html' => 'cea42fec3b6df18acb474070e3202078', + 'cgi/admin/templates/browser/browser_link_move.html' => 'c7e7f64911046ebc751879b8d974b004', + 'cgi/admin/templates/browser/browser_link_move_form.html' => 'e53dc8f79ae1582ebbd34313169330e6', + 'cgi/admin/templates/browser/browser_link_owner.html' => 'ace0ac87a1b6908f7d093d9cfd7a0ea3', + 'cgi/admin/templates/browser/browser_link_search_form.html' => 'd30f0d0795a9618d6b617438a59b4864', + 'cgi/admin/templates/browser/browser_link_search_results.html' => '8f1ffd2637c511739c7bda794852a281', + 'cgi/admin/templates/browser/browser_link_validate.html' => 'e61bfabcd5d65dadfe8d5bb5a508eef7', + 'cgi/admin/templates/browser/browser_link_validate_form.html' => 'aacc27e9f94578365dc924c194a0ce77', + 'cgi/admin/templates/browser/browser_navbar.html' => '2d8b69293aa5c601037f7fc70cbfdc52', + 'cgi/admin/templates/browser/browser_review_del_form.html' => '119d8766791267f28e496747b2e99262', + 'cgi/admin/templates/browser/browser_review_list.html' => '7bd9ec4e3426f199de8352d62fa41dd6', + 'cgi/admin/templates/browser/browser_review_modify_form.html' => 'ca69c26f71e604fce3b0472dd873d4fc', + 'cgi/admin/templates/browser/browser_review_result.html' => '9a162f1da69a80bbfad06da0700a1b5b', + 'cgi/admin/templates/browser/browser_reviews.html' => '3de7a11c8f500e2dd36150d48bbd07f2', + 'cgi/admin/templates/browser/browser_tree.html' => '87a95c2ec5cb19727762d325d8dec279', + 'cgi/admin/templates/browser/browser_validate_detailed.html' => '436a6484cd42a7712d8c3485ca90f732', + 'cgi/admin/templates/browser/browser_validate_detailed_form.html' => '11b3a5ff5f9103d28f42c610bd6ae6b3', + 'cgi/admin/templates/browser/browser_validate_links.html' => '6d7b50fc60ba711d9f6ddf20376df036', + 'cgi/admin/templates/luna/add.html' => '3c3cd47358356343bb73bb54461af0cb', + 'cgi/admin/templates/luna/add_success.html' => '30524c57d25f9b77df3e6901069e7259', + 'cgi/admin/templates/luna/bookmark_folder_add.html' => 'd00baa58235ef373423f05e35584af80', + 'cgi/admin/templates/luna/bookmark_folder_edit.html' => '6a6b9cb161b8b3194b7ec361a5ee119e', + 'cgi/admin/templates/luna/bookmark_folder_view.html' => 'c8a966acb495692b2d3376debdb407c4', + 'cgi/admin/templates/luna/bookmark_link.html' => 'd2e95ad222beccbd051fede93691123c', + 'cgi/admin/templates/luna/bookmark_link_add.html' => 'd14ea7d19c7ddafbd934b2897f76267b', + 'cgi/admin/templates/luna/bookmark_link_edit.html' => 'd930c2662e8be76e888fb0b2d62dff90', + 'cgi/admin/templates/luna/bookmark_list.html' => '52aeb43de4373dea184cd48900402279', + 'cgi/admin/templates/luna/bookmark_nav.html' => '2bc8da9c2eb5df757d5255d2cdddc362', + 'cgi/admin/templates/luna/bookmark_preferences.html' => '1e8cd1462cc5a83dfc5d0e7be59595c2', + 'cgi/admin/templates/luna/bookmark_users.html' => '56e85d18551b3824db620da188000238', + 'cgi/admin/templates/luna/category.html' => 'c884aca1f5147215b6d196f237558295', + 'cgi/admin/templates/luna/cool.html' => '84f65e1c98c45c273d1e6a4dfa9c016a', + 'cgi/admin/templates/luna/detailed.html' => '7da0eae9af91c1ddd9ba6a1001511439', + 'cgi/admin/templates/luna/error.html' => '0079c0cfd2751c6fb46981a3cfa315bc', + 'cgi/admin/templates/luna/home.html' => 'd973d214a2bf4939df1a71312a1822e1', + 'cgi/admin/templates/luna/include_accessibility.html' => 'a68efc2a34d354ac9600dfc09daeac46', + 'cgi/admin/templates/luna/include_common_head.html' => 'ac1dd4eef69a548715c15ed7d66e5c17', + 'cgi/admin/templates/luna/include_content_bottom.html' => 'd41d8cd98f00b204e9800998ecf8427e', + 'cgi/admin/templates/luna/include_content_top.html' => 'd41d8cd98f00b204e9800998ecf8427e', + 'cgi/admin/templates/luna/include_contentfooter.html' => '1e6949427fedea331766d72febb66a56', + 'cgi/admin/templates/luna/include_contentheader.html' => 'b9f2abb1fe8f38b9eedc6f5418bb0145', + 'cgi/admin/templates/luna/include_contentwrapper_bottom.html' => 'd41d8cd98f00b204e9800998ecf8427e', + 'cgi/admin/templates/luna/include_contentwrapper_top.html' => 'd41d8cd98f00b204e9800998ecf8427e', + 'cgi/admin/templates/luna/include_footer.html' => '36a4fa9191ff2635d46bdf8397a08fe7', + 'cgi/admin/templates/luna/include_form.html' => 'ae513878ca82eede62b4160e8c85f697', + 'cgi/admin/templates/luna/include_header.html' => '0ed4cf9a03f9492e9f597f182b03402b', + 'cgi/admin/templates/luna/include_leftsidebar.html' => 'c3314385891a50af98e72ae0a2133636', + 'cgi/admin/templates/luna/include_rightsidebar.html' => 'f11655111db437bf9c6163906a0abf5d', + 'cgi/admin/templates/luna/jump.html' => '06280130f092aaea5f5426d44a76728d', + 'cgi/admin/templates/luna/jump_frame.html' => 'e890222c51998e0e14c267082813a8ef', + 'cgi/admin/templates/luna/link.html' => '7eb70df28e06ef6ac4aac390249c4aa4', + 'cgi/admin/templates/luna/login.html' => 'b0c51f8e55e498ecbd4a007a2b30a547', + 'cgi/admin/templates/luna/login_email.html' => 'cc87d99a2ebeb4bdd73b17a90440ccc6', + 'cgi/admin/templates/luna/login_success.html' => '7d4c8245d01fee7d2e96def4e457a38b', + 'cgi/admin/templates/luna/modify.html' => 'b1bfd5e9daec3cd6240e041cad37fa50', + 'cgi/admin/templates/luna/modify_select.html' => '4b85af9b5b508c143d439ffa315335ad', + 'cgi/admin/templates/luna/modify_success.html' => 'a98ae6ed5d77f6b12e3fc7a867ba9765', + 'cgi/admin/templates/luna/new.html' => '1e364b7623d9f941ac1ba0fd2e212bdc', + 'cgi/admin/templates/luna/newsletter.html' => '5e03d230007394bd7c6865462c63e69a', + 'cgi/admin/templates/luna/newsletter_browse.html' => 'ca17f053a87d9d5815fb581af9b13997', + 'cgi/admin/templates/luna/newsletter_global.html' => 'db836b6f4091a5ba85c3967d0b2c7482', + 'cgi/admin/templates/luna/newsletter_list.html' => '5fac8dc09836a0014b7686c6240a5422', + 'cgi/admin/templates/luna/payment.html' => '815dbe89e82e12cd96978f0411f78095', + 'cgi/admin/templates/luna/payment_2checkout_include.html' => '0a1c0da36354e7f389740af6383f67b9', + 'cgi/admin/templates/luna/payment_direct.html' => 'eece1890127f35a9c7bd14bdebe7591e', + 'cgi/admin/templates/luna/payment_direct_include.html' => '986f7f44706cbd5b80b369b5b678fe10', + 'cgi/admin/templates/luna/payment_form.html' => '87561daf9582e8ecb2488b88e3730334', + 'cgi/admin/templates/luna/payment_manual_include.html' => 'd4d156f96692ae0fd5cc06abed573534', + 'cgi/admin/templates/luna/payment_method.html' => '02b3f2a5973efc195a9812c54715f545', + 'cgi/admin/templates/luna/payment_paypal_include.html' => '30e083a9636f323cc3de042c53d7d80d', + 'cgi/admin/templates/luna/payment_success.html' => 'b0c5ff0784a96a5bba6c98b7b81019de', + 'cgi/admin/templates/luna/payment_worldpay_include.html' => '017b51659ee3051daadd3ca3ab2c80a1', + 'cgi/admin/templates/luna/rate.html' => 'adc9d2f3828092b283d83e68e3fb2656', + 'cgi/admin/templates/luna/rate_success.html' => 'ff718de203db1c437b3c0c751225b82d', + 'cgi/admin/templates/luna/rate_top.html' => '00c09d6d8a7f3939128208f6151e1e7c', + 'cgi/admin/templates/luna/review_add.html' => 'cc7d7bd1e6836a69ccbbc49393ae7448', + 'cgi/admin/templates/luna/review_add_success.html' => '19b18580fae13fd6305edfdfaa59d591', + 'cgi/admin/templates/luna/review_edit.html' => 'a055aa6e3f780140eb538d60cc22b59f', + 'cgi/admin/templates/luna/review_edit_success.html' => '6e6809bf01cee7d21c6027b1e48c51d2', + 'cgi/admin/templates/luna/review_include.html' => 'be5f4449c41b80bf29339070987a9e00', + 'cgi/admin/templates/luna/review_search_results.html' => 'b89bc192317e8aa053e69ffe05188f6c', + 'cgi/admin/templates/luna/search.html' => 'e8091e0a6e875e4cba991d02d7080eba', + 'cgi/admin/templates/luna/search_results.html' => '77f7bc0eae386e0d86b74722b5927542', + 'cgi/admin/templates/luna/signup_form.html' => '297828ddab418b5b3e6387df17db4a92', + 'cgi/admin/templates/luna/signup_success.html' => '31dee8c59550b5235fc2504905022954', + 'cgi/admin/templates/luna/subcategory.html' => '81dc0694fa77ff322645173a6398729f', + 'cgi/admin/templates/luna/validate_form.html' => '3dc800f05385dc55b1452b354969212e', + 'cgi/admin/templates/luna/validate_success.html' => '23742f1a3340f9b17693db4ad744d80f', + 'cgi/bookmark.cgi' => 'b5369ee3a9ca630af460222417ed0a04', + 'cgi/browser.cgi' => 'f559bf030cea52014157f0c576e4ec5e', + 'cgi/jump.cgi' => 'dc2954cc6d187f4009ebf9d7977bc28a', + 'cgi/modify.cgi' => 'fab41ef5350f234c72b79ae9f6d952f5', + 'cgi/page.cgi' => 'c4df41f211aa931e5ab787f6c0f4698c', + 'cgi/postback.cgi' => '4c53206759e1365f430c265c24e8170e', + 'cgi/rate.cgi' => '60d5f4352ba133775648933863b6a281', + 'cgi/review.cgi' => '576d14185e537e21a1392aa372fd4ebb', + 'cgi/search.cgi' => '2599c0d3dc2769899d7eb9a437b15be9', + 'cgi/subscribe.cgi' => 'a9d2450db2556485b8b586c1ad273187', + 'cgi/treecats.cgi' => '5fbd24d7df7a44ceae862c1814bd20a6', + 'cgi/user.cgi' => '717b8230ce562aafbeb34da1c8a04c37', + 'html/static/fileman/tinymce/plugins/advhr/rule.htm' => 'c7f2e7569234a4ee4650ecde6d5053ac', + 'html/static/fileman/tinymce/plugins/advimage/image.htm' => '9c047eccb30c3073ebdf58abb7239a35', + 'html/static/fileman/tinymce/plugins/advlink/link.htm' => '28b4e8b3b295a9aad181667a71ad5a5a', + 'html/static/fileman/tinymce/plugins/fullpage/fullpage.htm' => 'a035917ad7ab45825b1aa44ceebc084c', + 'html/static/fileman/tinymce/plugins/media/media.htm' => '1f101c10c8c369f4466e95724148d454', + 'html/static/fileman/tinymce/plugins/paste/blank.htm' => '88783f6e539184616896268bca04c25e', + 'html/static/fileman/tinymce/plugins/paste/pastetext.htm' => 'a83b2f9eb0861b1bd5db22e57da4280d', + 'html/static/fileman/tinymce/plugins/paste/pasteword.htm' => 'ce42817c01ddd922c3f1c5c9701c0036', + 'html/static/fileman/tinymce/plugins/preview/example.html' => 'f6ae5a579ef4ef3b8648329395e6d0de', + 'html/static/fileman/tinymce/plugins/safari/blank.htm' => 'c9a4909a579f24cd23fc0ae847e06241', + 'html/static/fileman/tinymce/plugins/searchreplace/searchreplace.htm' => 'ae3fd1271c4d96722acbe34a10e43dc2', + 'html/static/fileman/tinymce/plugins/style/props.htm' => 'd4e3d92f757881513ad4200472b1e87c', + 'html/static/fileman/tinymce/plugins/table/cell.htm' => '31736b89077edd83afd52ffab4a8a83a', + 'html/static/fileman/tinymce/plugins/table/merge_cells.htm' => '031d824351b82c36fba89fadabb38951', + 'html/static/fileman/tinymce/plugins/table/row.htm' => '3a44d6da2354b63f96ce6fc1ebb9ce25', + 'html/static/fileman/tinymce/plugins/table/table.htm' => 'c655392d87b67af8331c7d2a8cdda4b5', + 'html/static/fileman/tinymce/themes/advanced/about.htm' => '2102cad8b48c2e05fa8ec2fd6be6c7e9', + 'html/static/fileman/tinymce/themes/advanced/anchor.htm' => 'fece56d073731444af6747bf65fbb257', + 'html/static/fileman/tinymce/themes/advanced/charmap.htm' => 'b3f3e37cff43d90e2fec656b52f1b67a', + 'html/static/fileman/tinymce/themes/advanced/color_picker.htm' => '01474b7f41da7d851c5a7f27aa2f2ff0', + 'html/static/fileman/tinymce/themes/advanced/image.htm' => '8008302022a40226c46f87fceac11f62', + 'html/static/fileman/tinymce/themes/advanced/link.htm' => '2951c33235fe77a9b2d20b50ade5bdfd', + 'html/static/fileman/tinymce/themes/advanced/source_editor.htm' => 'ad4599870c78219ce16abd5dc75159dc' +}; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/config.php b/site/slowtwitch.com/cgi-bin/articles/admin/config.php new file mode 100644 index 0000000..76db56d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/config.php @@ -0,0 +1,68 @@ += '4.0.4pl1' && strstr($_SERVER["HTTP_USER_AGENT"],'compatible')) { + if (extension_loaded('zlib')) { + ob_end_clean(); + ob_start('ob_gzhandler'); + } +} else if ($phpver > '4.0') { + if (strstr($HTTP_SERVER_VARS['HTTP_ACCEPT_ENCODING'], 'gzip')) { + if (extension_loaded('zlib')) { + $do_gzip_compress = TRUE; + ob_start(array('ob_gzhandler',5)); + ob_implicit_flush(0); + header('Content-Encoding: gzip'); + } + } +} +$phpver = explode(".", $phpver); +$phpver = "$phpver[0]$phpver[1]"; +if ($phpver >= 41) { + $PHP_SELF = $_SERVER['PHP_SELF']; +} + +if (!ini_get("register_globals")) { +# import_request_variables('GPC'); +} + +?> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/constants.pm b/site/slowtwitch.com/cgi-bin/articles/admin/constants.pm new file mode 100644 index 0000000..1965796 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/constants.pm @@ -0,0 +1,143 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# constants +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: constants.pm,v 1.9 2004/01/13 01:35:15 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Lightweight version of the standard constant.pm that allows you +# to declare multiple scalar constants in a single compile-time +# command. Like constant.pm, these scalar constants are optimized +# during Perl's compilation stage. +# Unlike constant.pm, this does not allow you to declare list +# constants. + +package constants; + + +use strict; +use Carp; +use vars qw($VERSION); + +$VERSION = '1.00'; + +#======================================================================= + +# Some of this stuff didn't work in version 5.003, alas. +require 5.003_96; + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + @_ or return; # Ignore 'use constant;' + my %constants = @_; + my $pkg = caller; + { + no strict 'refs'; + for my $name (keys %constants) { + croak qq{Can't define "$name" as constant} . + qq{ (name contains invalid characters or is empty)} + unless $name =~ /^[^\W_0-9]\w*$/; + my $scalar = $constants{$name}; + *{"${pkg}::$name"} = sub () { $scalar }; + } + } + +} + +1; + +__END__ + +=head1 NAME + +constants - Perl pragma to declare multiple scalar constants at once + +=head1 SYNOPSIS + + use constants BUFFER_SIZE => 4096, + ONE_YEAR => 365.2425 * 24 * 60 * 60, + PI => 4 * atan2 1, 1, + DEBUGGING => 0, + ORACLE => 'oracle@cs.indiana.edu', + USERNAME => scalar getpwuid($<); + + sub deg2rad { PI * $_[0] / 180 } + + print "This line does nothing" unless DEBUGGING; + + # references can be declared constants + use constants CHASH => { foo => 42 }, + CARRAY => [ 1,2,3,4 ], + CPSEUDOHASH => [ { foo => 1}, 42 ], + CCODE => sub { "bite $_[0]\n" }; + + print CHASH->{foo}; + print CARRAY->[$i]; + print CPSEUDOHASH->{foo}; + print CCODE->("me"); + print CHASH->[10]; # compile-time error + +=head1 DESCRIPTION + +This will declare a symbol to be a constant with the given scalar +value. This module mimics constant.pm in every way, except that it +allows multiple scalar constants to be created simultaneously. To +create constant list values you should use constant. + +See L for details about how constants work. + +=head1 NOTES + +The value or values are evaluated in a list context, so you should +override this if needed with C as shown above. + +=head1 TECHNICAL NOTE + +In the current implementation, scalar constants are actually +inlinable subroutines. As of version 5.004 of Perl, the appropriate +scalar constant is inserted directly in place of some subroutine +calls, thereby saving the overhead of a subroutine call. See +L for details about how and when this +happens. + +=head1 BUGS + +In the current version of Perl, list constants are not inlined +and some symbols may be redefined without generating a warning. + +It is not possible to have a subroutine or keyword with the same +name as a constant. This is probably a Good Thing. + +Unlike constants in some languages, these cannot be overridden +on the command line or via environment variables. + +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +For example, you can't say C<$hash{CONSTANT}> because C will +be interpreted as a string. Use C<$hash{CONSTANT()}> or +C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from +kicking in. Similarly, since the C<=E> operator quotes a bareword +immediately to its left you have to say C 'value'> +instead of C 'value'>. + +=head1 AUTHOR + +constant.pm: Tom Phoenix, EFE, with help from +many other folks. + +constants.pm: Jason Rhinelander, Gossamer Threads Inc. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/create_table.pl b/site/slowtwitch.com/cgi-bin/articles/admin/create_table.pl new file mode 100644 index 0000000..822fe7d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/create_table.pl @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +main(); + +sub main { +# ------------------------------------------------------------------ +# Main admin loop, displays html pages and other admin tasks. +# + my $c = $DB->creator('ClickTrack_Custom'); + $c->cols( { + click_id => { pos => 1, type => 'INT', not_null => 1 }, + click_date => { pos => 2, type => 'Date', not_null => 1 }, + click_linkid => { pos => 3, type => 'INT', not_null => 1 }, + }); + $c->pk('click_id'); + $c->ai('click_id'); + $c->fk( { + 'Links' => { click_linkid => 'ID' } + }); + my $res = $c->create(); + +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/cron/expiry_notify.pl b/site/slowtwitch.com/cgi-bin/articles/admin/cron/expiry_notify.pl new file mode 100755 index 0000000..1cd5665 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/cron/expiry_notify.pl @@ -0,0 +1,30 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: expiry_notify.pl,v 1.4 2005/04/14 07:48:46 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$CFG/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { +#----------------------------------------------------------------- +# + require Links::Payment; + Links::Payment::expiry($CFG->{payment}->{expiry_notify}); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/cron/most_popular.pl b/site/slowtwitch.com/cgi-bin/articles/admin/cron/most_popular.pl new file mode 100755 index 0000000..629ed9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/cron/most_popular.pl @@ -0,0 +1,29 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,068,085,094,083 +# Revision : $Id: expiry_notify.pl,v 1.4 2005/04/14 07:48:46 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$CFG $DB/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { +#----------------------------------------------------------------- +# + print Links::user_page('most_popular.html',{}); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/cullGlist.php b/site/slowtwitch.com/cgi-bin/articles/admin/cullGlist.php new file mode 100644 index 0000000..c63fca3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/cullGlist.php @@ -0,0 +1,31 @@ + + +
        +eml_code: +
        + + 50) { + echo "More than 50 results found"; + } else { + echo ""; + echo ""; + while ($row = mysql_fetch_array($query)) { + echo ""; + } + echo "
        Email AddressCode
        " . $row[eml_email] . "" . $row[eml_code] . "
        "; + } + +} +?> \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/database.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/database.def new file mode 100644 index 0000000..03cb946 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/database.def @@ -0,0 +1,18 @@ +# Database access & configuration file +# Last updated: Fri Aug 31 13:04:07 2007 +# Created by GT::SQL $Revision: 1.111 $ +{ + 'PREFIX' => 'glinks_', + 'PrintError' => '0', + 'RaiseError' => '0', + 'database' => 'slowtwitch', + 'def_path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/defs', + 'driver' => 'mysql', + 'host' => '192.168.1.10', + 'login' => 'slowtwitch', + 'obj_cache' => '1', + 'password' => 'k9volqlAcpq', + 'port' => undef +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Folders.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Folders.def new file mode 100644 index 0000000..d8770fe --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Folders.def @@ -0,0 +1,74 @@ +# Database definition file for 'glinks_Bookmark_Folders' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'my_folder_id', + 'cols' => { + 'my_folder_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'my_folder_name' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'my_folder_description' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '3', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'my_folder_user_username_fk' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '4', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'my_folder_default' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TINYINT', + 'unsigned' => '1' + }, + 'my_folder_public' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'TINYINT', + 'unsigned' => '1' + } + }, + 'fk' => { + 'glinks_Users' => { + 'my_folder_user_username_fk' => 'Username' + } + }, + 'fk_tables' => [ + 'glinks_Bookmark_Links' + ], + 'index' => {}, + 'pk' => [ + 'my_folder_id' + ], + 'subclass' => { + 'table' => {} + }, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Links.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Links.def new file mode 100644 index 0000000..bfc32c5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Bookmark_Links.def @@ -0,0 +1,66 @@ +# Database definition file for 'glinks_Bookmark_Links' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'my_id', + 'cols' => { + 'my_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'my_link_id_fk' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'my_user_username_fk' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '3', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'my_folder_id_fk' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'my_comment' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '5', + 'size' => '255', + 'type' => 'VARCHAR' + } + }, + 'fk' => { + 'glinks_Bookmark_Folders' => { + 'my_folder_id_fk' => 'my_folder_id' + }, + 'glinks_Links' => { + 'my_link_id_fk' => 'ID' + }, + 'glinks_Users' => { + 'my_user_username_fk' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'my_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatLinks.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatLinks.def new file mode 100644 index 0000000..3cb98dc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatLinks.def @@ -0,0 +1,52 @@ +# Database definition file for 'glinks_CatLinks' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'LinkID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'CategoryID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + } + }, + 'fk' => { + 'glinks_Category' => { + 'CategoryID' => 'ID' + }, + 'glinks_Links' => { + 'LinkID' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => { + 'lndx' => [ + 'LinkID' + ] + }, + 'pk' => [], + 'subclass' => { + 'table' => { + 'glinks_CatLinks' => 'Links::Table::CatLinks' + } + }, + 'unique' => { + 'cl_cl_q' => [ + 'CategoryID', + 'LinkID' + ] + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatPrice.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatPrice.def new file mode 100644 index 0000000..2988608 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatPrice.def @@ -0,0 +1,67 @@ +# Database definition file for 'glinks_CatPrice' table +# Last updated: Fri Aug 31 13:04:07 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'cp_id', + 'cols' => { + 'cp_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'cp_cat_id_fk' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'cp_term' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'size' => '10', + 'type' => 'CHAR' + }, + 'cp_cost' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'DOUBLE' + }, + 'cp_type' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TINYINT', + 'unsigned' => '1' + }, + 'cp_description' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '6', + 'type' => 'TEXT' + } + }, + 'fk' => { + 'glinks_Category' => { + 'cp_cat_id_fk' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'cp_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatRelations.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatRelations.def new file mode 100644 index 0000000..6feb243 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_CatRelations.def @@ -0,0 +1,48 @@ +# Database definition file for 'glinks_CatRelations' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'CategoryID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'RelatedID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'RelationName' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '3', + 'size' => '255', + 'type' => 'VARCHAR' + } + }, + 'fk' => { + 'glinks_Category' => { + 'CategoryID' => 'ID', + 'RelatedID' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => { + 'catid' => [ + 'CategoryID' + ] + }, + 'pk' => [], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category.def new file mode 100644 index 0000000..ec759f5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category.def @@ -0,0 +1,264 @@ +# Database definition file for 'glinks_Category' table +# Last updated: Sun Jun 10 22:17:08 2012 +# Created by GT::SQL::Table $Revision: 1.274 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_display' => 'ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Name' => { + 'form_display' => 'Name', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'regex' => '^[^/]+$', + 'size' => '255', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + 'FatherID' => { + 'default' => '0', + 'form_display' => 'Parent Category ID', + 'form_size' => '1', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'CatRoot' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'hidden', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'CatDepth' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'hidden', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Full_Name' => { + 'form_display' => 'Full Name', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '6', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'Description' => { + 'form_display' => 'Description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '7', + 'type' => 'LONGTEXT', + 'weight' => '1' + }, + 'Meta_Description' => { + 'form_display' => 'Meta Description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '8', + 'type' => 'LONGTEXT' + }, + 'Meta_Keywords' => { + 'form_display' => 'Meta Keywords', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '9', + 'type' => 'LONGTEXT' + }, + 'Header' => { + 'form_display' => 'Header', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '10', + 'type' => 'LONGTEXT' + }, + 'Footer' => { + 'form_display' => 'Footer', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '11', + 'type' => 'LONGTEXT' + }, + 'Category_Template' => { + 'form_display' => 'Category Template', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '12', + 'size' => '20', + 'type' => 'VARCHAR' + }, + 'Number_of_Links' => { + 'default' => '0', + 'form_display' => 'Number of Links', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '13', + 'type' => 'INT' + }, + 'Direct_Links' => { + 'default' => '0', + 'form_display' => 'Links (without subcats)', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '14', + 'type' => 'INT' + }, + 'Has_New_Links' => { + 'default' => 'No', + 'form_display' => 'Has New Links', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '15', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'Has_Changed_Links' => { + 'default' => 'No', + 'form_display' => 'Has Changed Links', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '16', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'Newest_Link' => { + 'form_display' => 'Newest Link', + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '17', + 'type' => 'DATE' + }, + 'Timestmp' => { + 'default' => 'CURRENT_TIMESTAMP', + 'form_display' => 'Timestamp', + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '18', + 'time_check' => '1', + 'type' => 'TIMESTAMP' + }, + 'Payment_Mode' => { + 'default' => '0', + 'form_display' => 'Payment Mode', + 'form_names' => [ + '0', + '1', + '2', + '3' + ], + 'form_size' => '1', + 'form_type' => 'SELECT', + 'form_values' => [ + 'Use global settings', + 'Not accepted', + 'Optional', + 'Required' + ], + 'not_null' => '1', + 'pos' => '19', + 'type' => 'TINYINT' + }, + 'Payment_Description' => { + 'form_display' => 'Payment Description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '20', + 'type' => 'LONGTEXT' + }, + 'Cat_Pos' => { + 'pos' => '21', + 'type' => 'INT' + }, + 'Featured_Links' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Featured Links', + 'form_size' => [ + '50', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '22', + 'regex' => '', + 'size' => '255', + 'type' => 'VARCHAR', + 'weight' => '' + } + }, + 'fk' => { + 'glinks_Category' => { + 'FatherID' => 'ID' + } + }, + 'fk_tables' => [ + 'glinks_Category_tree', + 'glinks_Category', + 'glinks_CatPrice', + 'glinks_CatLinks', + 'glinks_CatRelations', + 'glinks_Editors', + 'glinks_NewsletterSubscription' + ], + 'index' => { + 'c_p' => [ + 'Payment_Mode' + ], + 'catndx' => [ + 'Name' + ], + 'fthrindex' => [ + 'FatherID' + ], + 'namndx' => [ + 'Full_Name' + ], + 'rootndx' => [ + 'CatRoot' + ] + }, + 'pk' => [ + 'ID' + ], + 'subclass' => { + 'html' => { + 'glinks_Category' => 'Links::HTML::Category' + }, + 'relation' => {}, + 'table' => { + 'glinks_Category' => 'Links::Table::Category' + } + }, + 'tree' => '1', + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category_tree.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category_tree.def new file mode 100644 index 0000000..409097e Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Category_tree.def differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Changes.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Changes.def new file mode 100644 index 0000000..fb56d20 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Changes.def @@ -0,0 +1,53 @@ +# Database definition file for 'glinks_Changes' table +# Last updated: Fri Aug 31 13:04:07 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'LinkID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Username' => { + 'default' => 'admin', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '50', + 'type' => 'CHAR' + }, + 'ChgRequest' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '3', + 'type' => 'TEXT' + }, + 'Timestmp' => { + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '4', + 'type' => 'TIMESTAMP' + } + }, + 'fk' => { + 'glinks_Links' => { + 'LinkID' => 'ID' + }, + 'glinks_Users' => { + 'Username' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack.def new file mode 100644 index 0000000..1e9c11f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack.def @@ -0,0 +1,72 @@ +# Database definition file for 'glinks_ClickTrack' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'LinkID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT' + }, + 'IP' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '16', + 'type' => 'CHAR' + }, + 'ClickType' => { + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'ENUM', + 'values' => [ + 'Rate', + 'Hits', + 'Review' + ] + }, + 'ReviewID' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'INT' + }, + 'Created' => { + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TIMESTAMP' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => { + 'cndx' => [ + 'Created' + ] + }, + 'pk' => [], + 'subclass' => { + 'table' => { + 'glinks_ClickTrack' => 'Links::Table::ClickTrack' + } + }, + 'unique' => { + 'ct_licr' => [ + 'LinkID', + 'IP', + 'ClickType', + 'ReviewID' + ] + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack_Custom.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack_Custom.def new file mode 100644 index 0000000..7ef39f7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_ClickTrack_Custom.def @@ -0,0 +1,51 @@ +# Database definition file for 'glinks_ClickTrack_Custom' table +# Last updated: Tue Sep 4 14:44:33 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'click_id', + 'cols' => { + 'click_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT' + }, + 'click_date' => { + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'Date' + }, + 'click_linkid' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT' + }, + 'click_from' => { + 'form_size' => '15', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '4', + 'size' => '10', + 'type' => 'CHAR' + } + }, + 'fk' => { + 'glinks_Links' => { + 'click_linkid' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'click_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Editors.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Editors.def new file mode 100644 index 0000000..3c11dd7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Editors.def @@ -0,0 +1,187 @@ +# Database definition file for 'glinks_Editors' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'Username' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'size' => '50', + 'type' => 'CHAR' + }, + 'CategoryID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'CanAddCat' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanModCat' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanDelCat' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanMoveCat' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanAddLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '7', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanDelLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '8', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanModLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '9', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanCopyLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '10', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanMoveLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '11', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanValLink' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '12', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanModReview' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '13', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanAddRel' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '14', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'CanAddEdit' => { + 'default' => 'No', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '15', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + } + }, + 'fk' => { + 'glinks_Category' => { + 'CategoryID' => 'ID' + }, + 'glinks_Users' => { + 'Username' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [], + 'subclass' => {}, + 'unique' => { + 'edituserndx' => [ + 'Username', + 'CategoryID' + ] + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailMailings.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailMailings.def new file mode 100644 index 0000000..c4f066f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailMailings.def @@ -0,0 +1,57 @@ +# Database definition file for 'glinks_EmailMailings' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Mailing' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Email' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '3', + 'size' => '75', + 'type' => 'TEXT' + }, + 'Sent' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'TINYINT' + }, + 'LinkID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '5', + 'type' => 'INT', + 'unsigned' => '1' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'ID' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailTemplates.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailTemplates.def new file mode 100644 index 0000000..97dbf09 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_EmailTemplates.def @@ -0,0 +1,73 @@ +# Database definition file for 'glinks_EmailTemplates' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'Name' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '\S', + 'size' => '50', + 'type' => 'CHAR' + }, + 'MsgFrom' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '2', + 'regex' => '\A(?:\S+\@[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)+)\Z', + 'type' => 'TEXT' + }, + 'MsgFromName' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'TEXT' + }, + 'Subject' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'TEXT' + }, + 'Message' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'MEDIUMTEXT' + }, + 'MessageFormat' => { + 'default' => 'text', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'ENUM', + 'values' => [ + 'text', + 'html' + ] + }, + 'LinkTemplate' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '7', + 'type' => 'MEDIUMTEXT' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'Name' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links.def new file mode 100644 index 0000000..c97289f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links.def @@ -0,0 +1,2856 @@ +# Database definition file for 'glinks_Links' table +# Last updated: Fri Dec 6 11:20:16 2019 +# Created by GT::SQL::Table $Revision: 1.274 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_display' => 'ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Title' => { + 'form_display' => 'Title', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '100', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + 'URL' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'URL', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '3', + 'regex' => '', + 'size' => '255', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'LinkOwner' => { + 'default' => 'admin', + 'form_display' => 'LinkOwner', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'Add_Date' => { + 'default' => '0000-00-00', + 'form_display' => 'Add Date', + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'DATE' + }, + 'Mod_Date' => { + 'default' => '0000-00-00', + 'form_display' => 'Mod Date', + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'DATE' + }, + 'Description' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Abstract', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '7', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '1' + }, + 'Contact_Name' => { + 'form_display' => 'Contact Name', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '8', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'Contact_Email' => { + 'form_display' => 'Contact Email', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '9', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'Hits' => { + 'default' => '0', + 'form_display' => 'Hits', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '10', + 'regex' => '^\d+$', + 'type' => 'INT' + }, + 'isNew' => { + 'default' => 'No', + 'form_display' => 'isNew', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '11', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'isChanged' => { + 'default' => 'No', + 'form_display' => 'isChanged', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '12', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'isPopular' => { + 'default' => 'No', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'isPopular', + 'form_names' => [ + 'No', + 'Yes' + ], + 'form_size' => '0', + 'form_type' => 'SELECT', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '13', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ], + 'weight' => '' + }, + 'isValidated' => { + 'default' => 'Yes', + 'form_display' => 'isValidated', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '14', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'Rating' => { + 'default' => '0.00', + 'form_display' => 'Rating', + 'not_null' => '1', + 'pos' => '15', + 'precision' => '4', + 'regex' => '^(?:10(?:\.0*)?|\d(?:\.\d*)?)$', + 'scale' => '2', + 'type' => 'DECIMAL' + }, + 'Votes' => { + 'default' => '0', + 'form_display' => 'Votes', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '16', + 'regex' => '^\d+$', + 'type' => 'SMALLINT', + 'unsigned' => '1' + }, + 'Status' => { + 'default' => '0', + 'form_display' => 'Status', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '17', + 'regex' => '^-?\d+$', + 'type' => 'SMALLINT' + }, + 'Date_Checked' => { + 'form_display' => 'Date Checked', + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '18', + 'type' => 'DATETIME' + }, + 'Timestmp' => { + 'default' => 'CURRENT_TIMESTAMP', + 'form_display' => 'Timestamp', + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '19', + 'time_check' => '1', + 'type' => 'TIMESTAMP' + }, + 'ExpiryDate' => { + 'default' => '2147483647', + 'form_display' => 'Expiry Date', + 'form_size' => '35', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '20', + 'type' => 'INT' + }, + 'ExpiryCounted' => { + 'default' => '0', + 'form_display' => 'Expiry optimization', + 'form_size' => '10', + 'form_type' => 'hidden', + 'not_null' => '1', + 'pos' => '21', + 'type' => 'TINYINT' + }, + 'ExpiryNotify' => { + 'default' => '0', + 'form_display' => 'Expiry notification sent', + 'form_size' => '10', + 'form_type' => 'hidden', + 'not_null' => '1', + 'pos' => '22', + 'type' => 'TINYINT' + }, + 'LinkExpired' => { + 'form_display' => 'Free Link Expired', + 'form_size' => '10', + 'form_type' => 'hidden', + 'pos' => '23', + 'type' => 'INT' + }, + 'SlideShowCache' => { + 'form_size' => '30', + 'form_type' => 'HIDDEN', + 'pos' => '24', + 'type' => 'LONGTEXT' + }, + 'Image1' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image1', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '25', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image2' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image2', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '26', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image3' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image3', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '27', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image4' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image4', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '28', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image5' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image5', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '29', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image6' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image6', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '30', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image7' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image7', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '31', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image8' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image8', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '32', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image9' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image9', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '33', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image10' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image10', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '34', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image11' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image11', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '35', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image12' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image12', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '36', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image13' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image13', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '37', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image14' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image14', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '38', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image15' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image15', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '39', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image16' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image16', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '40', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image17' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '41', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image18' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '42', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image19' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '43', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Image20' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '44', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT' + }, + 'Paragraph1' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph1', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '45', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph2' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph2', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '46', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph3' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph3', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '47', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph4' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph4', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '48', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph5' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph5', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '49', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph6' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph6', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '50', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph7' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph7', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '51', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph8' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph8', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '52', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph9' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph9', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '53', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph10' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph10', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '54', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph11' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph11', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '55', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph12' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph12', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '56', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph13' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph13', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '57', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph14' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph14', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '58', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph15' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph15', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '59', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph16' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph16', + 'form_size' => [ + '40', + '6' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '60', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Paragraph17' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph17', + 'form_size' => '40,6', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '61', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'Paragraph18' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph18', + 'form_size' => '40,6', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '62', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'Paragraph19' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph19', + 'form_size' => '40,6', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '63', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'Paragraph20' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Paragraph20', + 'form_size' => '40,6', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '64', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'ad_zone1' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone1', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '65', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'ad_zone2' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone2', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '66', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'ad_zone3' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone3', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '67', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'ad_zone4' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone4', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '68', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'ad_zone5' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone5', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '65', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'ad_zone6' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'ad_zone6', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '66', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'Related_Article1' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related_Article1', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '67', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Related_Article2' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related_Article2', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '68', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Related_Article3' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related_Article3', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '69', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Related_Article4' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related_Article4', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '70', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Related_Article5' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related_Article5', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '71', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image1_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image1_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '72', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image2_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image2_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '73', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image3_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image3_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '74', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image4_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image4_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '75', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image5_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image5_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '76', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image6_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image6_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '77', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image7_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image7_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '78', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image8_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image8_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '79', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image9_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image9_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '80', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image10_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image10_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '81', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image11_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image11_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '82', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image12_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image12_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '83', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image13_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image13_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '84', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image14_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image14_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '85', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image15_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image15_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '86', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image16_medium' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image16_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '87', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image17_medium' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '88', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image18_medium' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '89', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image19_medium' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '90', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image20_medium' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20_medium', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '91', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image1_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image1_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '92', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image2_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image2_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '93', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image3_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image3_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '94', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image4_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image4_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '95', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image5_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image5_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '96', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image6_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image6_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '97', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image7_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image7_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '98', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image8_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image8_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '99', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image9_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image9_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '100', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image10_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image10_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '101', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image11_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image11_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '102', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image12_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image12_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '103', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image13_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image13_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '104', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image14_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image14_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '105', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image15_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image15_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '106', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image16_thumbnail' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'form_display' => 'Image16_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'pos' => '107', + 'size' => '200', + 'type' => 'TINYTEXT' + }, + 'Image17_thumbnail' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '108', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image18_thumbnail' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '109', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image19_thumbnail' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '110', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image20_thumbnail' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20_thumbnail', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '111', + 'regex' => '', + 'size' => '200', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image1_description' => { + 'form_display' => 'Image1_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '112', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image2_description' => { + 'form_display' => 'Image2_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '113', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image3_description' => { + 'form_display' => 'Image3_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '114', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image4_description' => { + 'form_display' => 'Image4_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '115', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image5_description' => { + 'form_display' => 'Image5_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '116', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image6_description' => { + 'form_display' => 'Image6_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '117', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image7_description' => { + 'form_display' => 'Image7_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '118', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image8_description' => { + 'form_display' => 'Image8_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '119', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image9_description' => { + 'form_display' => 'Image9_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '120', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image10_description' => { + 'form_display' => 'Image10_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '121', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image11_description' => { + 'form_display' => 'Image11_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '122', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image12_description' => { + 'form_display' => 'Image12_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '123', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image13_description' => { + 'form_display' => 'Image13_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '124', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image14_description' => { + 'form_display' => 'Image14_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '125', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image15_description' => { + 'form_display' => 'Image15_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '126', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image16_description' => { + 'form_display' => 'Image16_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '127', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image17_description' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '128', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image18_description' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '129', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image19_description' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '130', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image20_description' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20_description', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '131', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Image1_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image1_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '132', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image2_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image2_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '133', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image3_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image3_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '134', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image4_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image4_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '135', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image5_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image5_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '136', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image6_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image6_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '137', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image7_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image7_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '138', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image8_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image8_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '139', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image9_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image9_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '140', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image10_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image10_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '141', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image11_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image11_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '142', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image12_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image12_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '143', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image13_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image13_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '144', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image14_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image14_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '145', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image15_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image15_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '146', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image16_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image16_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '147', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image17_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '148', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image18_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '149', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image19_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '150', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image20_large' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20_large', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '151', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Type' => { + 'default' => 'editorial', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Type', + 'form_names' => [ + 'editorial', + 'news' + ], + 'form_size' => '1', + 'form_type' => 'SELECT', + 'form_values' => [ + 'Latest Tech', + 'Latest News' + ], + 'not_null' => '0', + 'pos' => '152', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'editorial', + 'news' + ], + 'weight' => '' + }, + 'RelatedArticles' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related Article IDs', + 'form_size' => [ + '30', + '5' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '153', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'RelatedPhotos' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Related Photo IDs', + 'form_size' => [ + '30', + '5' + ], + 'form_type' => 'TEXTAREA', + 'not_null' => '0', + 'pos' => '154', + 'regex' => '', + 'type' => 'LONGTEXT', + 'weight' => '' + }, + 'Link_Type' => { + 'default' => 'article', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Link Type', + 'form_names' => [ + 'article', + 'photo', + 'video' + ], + 'form_size' => '1', + 'form_type' => 'SELECT', + 'form_values' => [ + 'Article', + 'Photo Gallery', + 'Video' + ], + 'not_null' => '1', + 'pos' => '155', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'article', + 'photo', + 'video' + ], + 'weight' => '' + }, + 'Orig_ID' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Orig_ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '156', + 'regex' => '', + 'type' => 'INT', + 'unsigned' => '1', + 'weight' => '' + }, + 'Image_URL' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image_URL', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '157', + 'regex' => '', + 'size' => '255', + 'type' => 'CHAR', + 'weight' => '' + }, + 'Thumbnail_URL' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Thumbnail_URL', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '158', + 'regex' => '', + 'size' => '255', + 'type' => 'CHAR', + 'weight' => '' + }, + 'File_Path' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_max_size' => '471859200', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'File_Path', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '159', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image_Path' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image_Path', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '160', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Flash_Path' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Flash_Path', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '161', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Thumbnail_Path' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/videos', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Thumbnail_Path', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '162', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Tag' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Tag', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '163', + 'regex' => '', + 'size' => '255', + 'type' => 'CHAR', + 'weight' => '' + }, + 'Family_Friendly' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Family_Friendly', + 'form_names' => [ + 'No', + 'Yes' + ], + 'form_size' => '', + 'form_type' => 'SELECT', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '164', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ], + 'weight' => '' + }, + 'Duration' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Duration', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '165', + 'regex' => '^\d+$', + 'type' => 'SMALLINT', + 'weight' => '' + }, + 'hasVideo' => { + 'default' => 'No', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'hasVideo', + 'form_names' => [ + 'No', + 'Yes' + ], + 'form_size' => '0', + 'form_type' => 'SELECT', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '166', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ], + 'weight' => '' + }, + 'showLargePic' => { + 'default' => 'No', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'showLargePic', + 'form_names' => [ + 'No', + 'Yes' + ], + 'form_size' => '0', + 'form_type' => 'SELECT', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '167', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ], + 'weight' => '' + }, + 'Image1_largest' => { + 'file_log_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image1_largest', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '168', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image2_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image2_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '169', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image3_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image3_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '170', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image4_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image4_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '171', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image5_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image5_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '172', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image6_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image6_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '173', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image7_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image7_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '174', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image8_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image8_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '175', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image9_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image9_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '176', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image10_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image10_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '177', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image11_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image11_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '178', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image12_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image12_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '179', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image13_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image13_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '180', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image14_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image14_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '181', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image15_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image15_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '182', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image16_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image16_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '183', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image17_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image17_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '184', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image18_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image18_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '185', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image19_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image19_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '186', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'Image20_largest' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/articles/images', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Image20_largest', + 'form_size' => '', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '187', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + 'weight' => '' + }, + 'twitter_published' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'twitter_published', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '188', + 'regex' => '', + 'size' => '20', + 'type' => 'CHAR', + 'weight' => '' + }, + 'facebook_published' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'facebook_published', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '189', + 'regex' => '', + 'type' => 'TINYINT', + 'weight' => '' + }, + 'twitter_published_message' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'twitter_published_message', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '190', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'facebook_published_message' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'facebook_published_message', + 'form_size' => '30', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '191', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'facebook_published_image' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'facebook_published_image', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '192', + 'regex' => '', + 'size' => '10', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'facebook_hashtags' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'facebook_hashtags', + 'form_size' => '30', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '193', + 'regex' => '', + 'type' => 'TEXT', + 'weight' => '' + }, + 'tag_swim' => { + 'default' => '0', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Swim', + 'form_names' => [ + '0', + '1' + ], + 'form_size' => '10', + 'form_type' => 'RADIO', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '194', + 'regex' => '', + 'type' => 'TINYINT', + 'weight' => '' + }, + 'tag_bike' => { + 'default' => '0', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Bike', + 'form_names' => [ + '0', + '1' + ], + 'form_size' => '10', + 'form_type' => 'RADIO', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '195', + 'regex' => '', + 'type' => 'TINYINT', + 'weight' => '' + }, + 'tag_run' => { + 'default' => '0', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Run', + 'form_names' => [ + '0', + '1' + ], + 'form_size' => '10', + 'form_type' => 'RADIO', + 'form_values' => [ + 'No', + 'Yes' + ], + 'not_null' => '0', + 'pos' => '196', + 'regex' => '', + 'type' => 'TINYINT', + 'weight' => '' + }, + }, + 'fk' => { + 'glinks_Users' => { + 'LinkOwner' => 'Username' + } + }, + 'fk_tables' => [ + 'glinks_Changes', + 'glinks_Reviews', + 'glinks_CatLinks', + 'glinks_Verify', + 'glinks_Payments', + 'glinks_Bookmark_Links', + 'glinks_ClickTrack_Custom' + ], + 'index' => { + 'expcntndx' => [ + 'ExpiryCounted', + 'ExpiryDate' + ], + 'expiryndx' => [ + 'ExpiryDate', + 'ExpiryNotify' + ], + 'newndx' => [ + 'isNew' + ], + 'stndx' => [ + 'Status' + ], + 'userndx' => [ + 'LinkOwner' + ], + 'valexpndx' => [ + 'isValidated', + 'ExpiryDate' + ] + }, + 'pk' => [ + 'ID' + ], + 'search_driver' => 'NONINDEXED', + 'subclass' => { + 'html' => { + 'glinks_Links' => 'Links::HTML::Links' + }, + 'relation' => {}, + 'table' => { + 'glinks_Links' => 'Links::Table::Links' + } + }, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links_Files.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links_Files.def new file mode 100644 index 0000000..dea6fd6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Links_Files.def @@ -0,0 +1,85 @@ +# Database definition file for 'glinks_Links_Files' table +# Last updated: Tue Sep 4 09:35:44 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'ForeignColName' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'ForeignColKey' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'File_Name' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '4', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'File_Directory' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '5', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'File_MimeType' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '6', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'File_Size' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '7', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'File_URL' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '8', + 'size' => '255', + 'type' => 'VARCHAR' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => { + 'fk_lookup' => [ + 'ForeignColName', + 'ForeignColKey' + ] + }, + 'pk' => [ + 'ID' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingIndex.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingIndex.def new file mode 100644 index 0000000..2a3e2af --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingIndex.def @@ -0,0 +1,78 @@ +# Database definition file for 'glinks_MailingIndex' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'Mailing', + 'cols' => { + 'Mailing' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'extra' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'TINYTEXT' + }, + 'done' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '3', + 'type' => 'INT' + }, + 'mailfrom' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'TEXT' + }, + 'name' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TEXT' + }, + 'subject' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'TEXT' + }, + 'message' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '7', + 'type' => 'MEDIUMTEXT' + }, + 'messageformat' => { + 'default' => 'text', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '8', + 'type' => 'ENUM', + 'values' => [ + 'text', + 'html' + ] + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'Mailing' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingList.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingList.def new file mode 100644 index 0000000..92faf89 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingList.def @@ -0,0 +1,35 @@ +# Database definition file for 'glinks_MailingList' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT' + }, + 'Email' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '255', + 'type' => 'CHAR' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => { + 'maillistndx' => [ + 'Email' + ] + }, + 'pk' => [], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingListIndex.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingListIndex.def new file mode 100644 index 0000000..4d2e66a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_MailingListIndex.def @@ -0,0 +1,48 @@ +# Database definition file for 'glinks_MailingListIndex' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Name' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '255', + 'type' => 'CHAR' + }, + 'DateModified' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT' + }, + 'DateCreated' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'INT' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'ID' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_NewsletterSubscription.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_NewsletterSubscription.def new file mode 100644 index 0000000..73f7ce3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_NewsletterSubscription.def @@ -0,0 +1,42 @@ +# Database definition file for 'glinks_NewsletterSubscription' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'UserID' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '1', + 'size' => '50', + 'type' => 'CHAR' + }, + 'CategoryID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT' + } + }, + 'fk' => { + 'glinks_Category' => { + 'CategoryID' => 'ID' + }, + 'glinks_Users' => { + 'UserID' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [], + 'subclass' => {}, + 'unique' => { + 'ns_uc' => [ + 'UserID', + 'CategoryID' + ] + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PageWidgets.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PageWidgets.def new file mode 100644 index 0000000..dfe1458 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PageWidgets.def @@ -0,0 +1,48 @@ +# Database definition file for 'glinks_CatLinks' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_display' => 'ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Page' => { + 'type' => 'VARCHAR', + 'size' => '255', + 'not_null' => '1', + }, + 'WidgetID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Sort_Pos' => { + 'type' => 'INT', + 'default' => '0' + } + }, + 'fk' => { + 'glinks_Widgets' => { + 'WidgetID' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => { + }, + 'pk' => [], + 'unique' => { + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PaymentLogs.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PaymentLogs.def new file mode 100644 index 0000000..ee5df44 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_PaymentLogs.def @@ -0,0 +1,78 @@ +# Database definition file for 'glinks_PaymentLogs' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'paylogs_id', + 'cols' => { + 'paylogs_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'paylogs_payments_id' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '16', + 'type' => 'CHAR' + }, + 'paylogs_type' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'paylogs_time' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'paylogs_viewed' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TINYINT', + 'unsigned' => '1' + }, + 'paylogs_text' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '6', + 'type' => 'TEXT' + } + }, + 'fk' => { + 'glinks_Payments' => { + 'paylogs_payments_id' => 'payments_id' + } + }, + 'fk_tables' => [], + 'index' => { + 'pl_t' => [ + 'paylogs_time' + ], + 'pl_yt' => [ + 'paylogs_type', + 'paylogs_time' + ] + }, + 'pk' => [ + 'paylogs_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Payments.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Payments.def new file mode 100644 index 0000000..d47e47b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Payments.def @@ -0,0 +1,111 @@ +# Database definition file for 'glinks_Payments' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'payments_id' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'size' => '16', + 'type' => 'CHAR' + }, + 'payments_linkid' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'payments_status' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'payments_method' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'size' => '25', + 'type' => 'CHAR' + }, + 'payments_type' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'TINYINT', + 'unsigned' => '1' + }, + 'payments_amount' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'DOUBLE' + }, + 'payments_term' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '7', + 'size' => '10', + 'type' => 'CHAR' + }, + 'payments_start' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '8', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'payments_last' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '9', + 'type' => 'INT', + 'unsigned' => '1' + } + }, + 'fk' => { + 'glinks_Links' => { + 'payments_linkid' => 'ID' + } + }, + 'fk_tables' => [ + 'glinks_PaymentLogs' + ], + 'index' => { + 'p_al' => [ + 'payments_amount', + 'payments_last' + ], + 'p_ll' => [ + 'payments_linkid', + 'payments_last' + ], + 'p_sl' => [ + 'payments_status', + 'payments_last' + ] + }, + 'pk' => [ + 'payments_id' + ], + 'subclass' => { + 'table' => {} + }, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Reviews.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Reviews.def new file mode 100644 index 0000000..ca243fb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Reviews.def @@ -0,0 +1,166 @@ +# Database definition file for 'glinks_Reviews' table +# Last updated: Sun May 17 15:36:17 2009 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ReviewID', + 'cols' => { + 'ReviewID' => { + 'form_display' => 'Review ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Review_LinkID' => { + 'form_display' => 'Review Link ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Review_Owner' => { + 'form_display' => 'Review Owner', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'size' => '50', + 'type' => 'CHAR' + }, + 'Review_Rating' => { + 'default' => '0', + 'form_display' => 'Review Rating', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '4', + 'regex' => '^\d+$', + 'type' => 'SMALLINT', + 'unsigned' => '1' + }, + 'Review_Date' => { + 'form_display' => 'Review Date', + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'DATETIME' + }, + 'Review_ModifyDate' => { + 'form_display' => 'Review Modify Date', + 'form_size' => '20', + 'form_type' => 'DATE', + 'not_null' => '1', + 'pos' => '6', + 'type' => 'DATETIME' + }, + 'Review_Subject' => { + 'form_display' => 'Review Subject', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '7', + 'size' => '100', + 'type' => 'CHAR' + }, + 'Review_Contents' => { + 'form_display' => 'Review Contents', + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '8', + 'type' => 'TEXT' + }, + 'Review_ByLine' => { + 'form_display' => 'Review By Line', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '9', + 'size' => '50', + 'type' => 'CHAR' + }, + 'Review_WasHelpful' => { + 'form_display' => 'Review Was Helpful', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '10', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Review_WasNotHelpful' => { + 'form_display' => 'Review Was Not Helpful', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '11', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Review_Validated' => { + 'default' => 'No', + 'form_display' => 'Review Validated', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '12', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'Review_GuestName' => { + 'form_display' => 'Review Guest Name', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '13', + 'size' => '75', + 'type' => 'CHAR' + }, + 'Review_GuestEmail' => { + 'form_display' => 'Review Guest Email', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '14', + 'regex' => '^(?:(?:.+\@.+\..+)|\s*)$', + 'size' => '75', + 'type' => 'CHAR' + } + }, + 'fk' => { + 'glinks_Links' => { + 'Review_LinkID' => 'ID' + }, + 'glinks_Users' => { + 'Review_Owner' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => { + 'rdatendx' => [ + 'Review_Date' + ], + 'rlinkndx' => [ + 'Review_LinkID' + ], + 'rownerndx' => [ + 'Review_Owner' + ] + }, + 'pk' => [ + 'ReviewID' + ], + 'subclass' => { + 'table' => { + 'glinks_Reviews' => 'Links::Table::Reviews' + } + }, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_SearchLogs.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_SearchLogs.def new file mode 100644 index 0000000..ba07fd7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_SearchLogs.def @@ -0,0 +1,56 @@ +# Database definition file for 'glinks_SearchLogs' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'slog_query' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'slog_count' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT' + }, + 'slog_hits' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT' + }, + 'slog_time' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '4', + 'type' => 'FLOAT' + }, + 'slog_last' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '5', + 'type' => 'INT' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'slog_query' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Sessions.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Sessions.def new file mode 100644 index 0000000..eb83098 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Sessions.def @@ -0,0 +1,59 @@ +# Database definition file for 'glinks_Sessions' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'session_id' => { + 'binary' => '1', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'size' => '32', + 'type' => 'CHAR' + }, + 'session_user_id' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '50', + 'type' => 'CHAR' + }, + 'session_date' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'INT' + }, + 'session_expires' => { + 'default' => '1', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'pos' => '4', + 'type' => 'TINYINT' + }, + 'session_data' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'pos' => '5', + 'type' => 'TEXT' + } + }, + 'fk' => { + 'glinks_Users' => { + 'session_user_id' => 'Username' + } + }, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'session_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Ticker.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Ticker.def new file mode 100644 index 0000000..ed86e62 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Ticker.def @@ -0,0 +1,39 @@ +# Database definition file for 'glinks_Ticker' table +# Last updated: Mon Jun 14 13:48:02 2010 +# Created by GT::SQL::Table $Revision: 1.274 $ +{ + 'ai' => 'ticker_id', + 'cols' => { + 'ticker_id' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT' + }, + 'ticker_text' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'TEXT' + }, + 'ticker_link' => { + 'form_size' => '30', + 'form_type' => 'TEXTAREA', + 'not_null' => '1', + 'pos' => '3', + 'type' => 'TEXT' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => {}, + 'pk' => [ + 'ticker_id' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Users.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Users.def new file mode 100644 index 0000000..4a15897 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Users.def @@ -0,0 +1,172 @@ +# Database definition file for 'glinks_Users' table +# Last updated: Tue Aug 26 09:27:10 2008 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'Username' => { + 'form_display' => 'Username', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'size' => '50', + 'type' => 'CHAR' + }, + 'Password' => { + 'binary' => '1', + 'form_display' => 'Password', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '25', + 'type' => 'CHAR' + }, + 'Email' => { + 'form_display' => 'Email', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'regex' => '^(?:.+\@.+\..+|\s*)$', + 'size' => '75', + 'type' => 'CHAR' + }, + 'Name' => { + 'form_display' => 'Name', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '4', + 'size' => '75', + 'type' => 'CHAR' + }, + 'Validation' => { + 'form_display' => 'Validation Code', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '5', + 'size' => '20', + 'type' => 'CHAR' + }, + 'Status' => { + 'default' => 'Registered', + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'Status', + 'form_names' => [ + 'Not Validated', + 'Registered', + 'Administrator', + 'Editor' + ], + 'form_size' => '0', + 'form_type' => 'SELECT', + 'form_values' => [ + 'Not Validated', + 'Registered', + 'Administrator', + 'Editor' + ], + 'not_null' => '1', + 'pos' => '6', + 'regex' => '', + 'type' => 'ENUM', + 'values' => [ + 'Not Validated', + 'Registered', + 'Administrator', + 'Editor' + ] + }, + 'ReceiveMail' => { + 'default' => 'Yes', + 'form_display' => 'Receive Mailings', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '7', + 'type' => 'ENUM', + 'values' => [ + 'No', + 'Yes' + ] + }, + 'SortField' => { + 'default' => 'Title', + 'form_display' => 'Bookmark sort field', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '8', + 'regex' => '^[\s\w]+$', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'SortOrd' => { + 'default' => 'ASC', + 'form_display' => 'Bookmark sort order', + 'form_type' => 'SELECT', + 'not_null' => '1', + 'pos' => '9', + 'type' => 'ENUM', + 'values' => [ + 'ASC', + 'DESC' + ] + }, + 'PerPage' => { + 'default' => '15', + 'form_display' => 'Bookmarks per page', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '10', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Grouping' => { + 'default' => '0', + 'form_display' => 'Bookmark grouping', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '11', + 'type' => 'TINYINT', + 'unsigned' => '1' + } + }, + 'fk' => {}, + 'fk_tables' => [ + 'glinks_Links', + 'glinks_Changes', + 'glinks_Reviews', + 'glinks_Editors', + 'glinks_Sessions', + 'glinks_Bookmark_Folders', + 'glinks_Bookmark_Links', + 'glinks_NewsletterSubscription' + ], + 'index' => { + 'emailndx' => [ + 'Email' + ] + }, + 'pk' => [ + 'Username' + ], + 'search_driver' => 'NONINDEXED', + 'subclass' => { + 'html' => { + 'glinks_Users' => 'Links::HTML::Users' + }, + 'relation' => {}, + 'table' => { + 'glinks_Users' => 'Links::Table::Users' + } + }, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Verify.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Verify.def new file mode 100644 index 0000000..117ea29 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Verify.def @@ -0,0 +1,46 @@ +# Database definition file for 'glinks_Verify' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => '', + 'cols' => { + 'LinkID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Status' => { + 'default' => '0', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'SMALLINT' + }, + 'Date_Checked' => { + 'form_size' => '20', + 'form_type' => 'DATE', + 'pos' => '3', + 'type' => 'DATE' + } + }, + 'fk' => { + 'glinks_Links' => { + 'LinkID' => 'ID' + } + }, + 'fk_tables' => [], + 'index' => { + 'veriflndx' => [ + 'LinkID' + ] + }, + 'pk' => [], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_WidgetLinks.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_WidgetLinks.def new file mode 100644 index 0000000..82ecfa6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_WidgetLinks.def @@ -0,0 +1,70 @@ +# Database definition file for 'glinks_CatLinks' table +# Last updated: Fri Aug 31 13:04:08 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'WidgetID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Title' => { + 'form_display' => 'Title', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '100', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + 'Abstract' => { + 'form_display' => 'Title', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '2', + 'type' => 'TEXT', + 'weight' => '3' + }, + 'URL' => { + 'form_display' => 'Title', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '255', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + }, + 'fk' => { + 'glinks_Widgets' => { + 'WidgetID' => 'ID' + }, + }, + 'fk_tables' => [], + 'index' => { + }, + 'pk' => [ + 'ID' + ], + 'subclass' => { + }, + 'unique' => { + } +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets.def new file mode 100644 index 0000000..253ed92 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets.def @@ -0,0 +1,144 @@ +# Database definition file for 'glinks_Links' table +# Last updated: Tue Nov 12 16:36:16 2013 +# Created by GT::SQL::Table $Revision: 1.274 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_display' => 'ID', + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'Title' => { + 'form_display' => 'Title', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '2', + 'size' => '100', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + 'Subtitle' => { + 'form_display' => 'Subtitle', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '', + 'pos' => '3', + 'type' => 'TEXT', + 'weight' => '3' + }, + 'TitleStyle' => { + 'form_display' => 'Css', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '', + 'pos' => '4', + 'type' => 'TEXT', + 'weight' => '3' + }, + 'Image' => { + 'file_max_size' => '', + 'file_save_in' => '/var/home/slowtwitch/slowtwitch.com/www/images/widgets', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '/images/widgets', + 'form_display' => 'Image', + 'form_size' => '20', + 'form_type' => 'FILE', + 'not_null' => '0', + 'pos' => '4', + 'regex' => '', + 'size' => '255', + 'type' => 'TINYTEXT', + }, + 'URL' => { + 'file_max_size' => '', + 'file_save_in' => '', + 'file_save_scheme' => 'HASHED', + 'file_save_url' => '', + 'form_display' => 'URL', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '5', + 'regex' => '', + 'size' => '255', + 'type' => 'VARCHAR', + 'weight' => '' + }, + 'Button' => { + 'form_display' => 'Button', + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '', + 'pos' => '6', + 'size' => '100', + 'type' => 'VARCHAR', + 'weight' => '3' + }, + 'Type' => { + 'form_display' => 'Widget Type', + 'not_null' => '', + 'default' => '0', + 'pos' => '8', + 'size' => '100', + 'type' => 'TINYINT', + }, + 'Widget' => { + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '7', + 'regex' => '', + 'type' => 'VARCHAR', + 'size' => '30', + 'weight' => '' + }, + 'ListID' => { + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '6', + 'regex' => '', + 'type' => 'INT', + 'weight' => '' + }, + 'Articles' => { + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '7', + 'regex' => '', + 'type' => 'VARCHAR', + 'size' => '255', + 'weight' => '' + }, + 'Category' => { + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '7', + 'regex' => '', + 'type' => 'INT', + 'weight' => '' + }, + 'Forum' => { + 'form_type' => 'TEXT', + 'not_null' => '0', + 'pos' => '7', + 'regex' => '', + 'type' => 'INT', + 'weight' => '' + }, + }, + 'pk' => [ + 'ID' + ], + 'fk_tables' => [ + 'glinks_PageWidgets', + ], + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets_Files.def b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets_Files.def new file mode 100644 index 0000000..dea6fd6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/defs/glinks_Widgets_Files.def @@ -0,0 +1,85 @@ +# Database definition file for 'glinks_Links_Files' table +# Last updated: Tue Sep 4 09:35:44 2007 +# Created by GT::SQL::Table $Revision: 1.255 $ +{ + 'ai' => 'ID', + 'cols' => { + 'ID' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '1', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'ForeignColName' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '2', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'ForeignColKey' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '3', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'File_Name' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '4', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'File_Directory' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '5', + 'size' => '255', + 'type' => 'VARCHAR' + }, + 'File_MimeType' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '6', + 'size' => '50', + 'type' => 'VARCHAR' + }, + 'File_Size' => { + 'form_size' => '10', + 'form_type' => 'TEXT', + 'not_null' => '1', + 'pos' => '7', + 'regex' => '^\d+$', + 'type' => 'INT', + 'unsigned' => '1' + }, + 'File_URL' => { + 'form_size' => '20', + 'form_type' => 'TEXT', + 'pos' => '8', + 'size' => '255', + 'type' => 'VARCHAR' + } + }, + 'fk' => {}, + 'fk_tables' => [], + 'index' => { + 'fk_lookup' => [ + 'ForeignColName', + 'ForeignColKey' + ] + }, + 'pk' => [ + 'ID' + ], + 'subclass' => {}, + 'unique' => {} +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysql.class.php b/site/slowtwitch.com/cgi-bin/articles/admin/mysql.class.php new file mode 100644 index 0000000..fc69db7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysql.class.php @@ -0,0 +1,339 @@ +persistency = $persistency; + $this->user = $sqluser; + $this->password = $sqlpassword; + $this->server = $sqlserver; + $this->dbname = $database; + + if($this->persistency) + { + $this->db_connect_id = @mysql_pconnect($this->server, $this->user, $this->password); + } + else + { + $this->db_connect_id = @mysql_connect($this->server, $this->user, $this->password); + } + if($this->db_connect_id) + { + if($database != "") + { + $this->dbname = $database; + $dbselect = @mysql_select_db($this->dbname); + if(!$dbselect) + { + @mysql_close($this->db_connect_id); + $this->db_connect_id = $dbselect; + } + } + return $this->db_connect_id; + } + else + { + return false; + } + } + + // + // Other base methods + // + function sql_close() + { + if($this->db_connect_id) + { + if($this->query_result) + { + @mysql_free_result($this->query_result); + } + $result = @mysql_close($this->db_connect_id); + return $result; + } + else + { + return false; + } + } + + // + // Base query method + // + function sql_query($query = "", $transaction = FALSE) + { + // Remove any pre-existing queries + unset($this->query_result); + if($query != "") + { + + $this->query_result = @mysql_query($query, $this->db_connect_id); + + } + if($this->query_result) + { + unset($this->row[$this->query_result]); + unset($this->rowset[$this->query_result]); + return $this->query_result; + } + else + { + return ( $transaction == END_TRANSACTION ) ? true : false; + } + } + + // + // Other query methods + // + function sql_numrows($query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $result = @mysql_num_rows($query_id); + return $result; + } + else + { + return false; + } + } + function sql_affectedrows() + { + if($this->db_connect_id) + { + $result = @mysql_affected_rows($this->db_connect_id); + return $result; + } + else + { + return false; + } + } + function sql_numfields($query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $result = @mysql_num_fields($query_id); + return $result; + } + else + { + return false; + } + } + function sql_fieldname($offset, $query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $result = @mysql_field_name($query_id, $offset); + return $result; + } + else + { + return false; + } + } + function sql_fieldtype($offset, $query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $result = @mysql_field_type($query_id, $offset); + return $result; + } + else + { + return false; + } + } + function sql_fetchrow($query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $this->row[$query_id] = @mysql_fetch_array($query_id); + return $this->row[$query_id]; + } + else + { + return false; + } + } + function sql_fetchrowset($query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + unset($this->rowset[$query_id]); + unset($this->row[$query_id]); + while($this->rowset[$query_id] = @mysql_fetch_array($query_id)) + { + $result[] = $this->rowset[$query_id]; + } + return $result; + } + else + { + return false; + } + } + function sql_fetchfield($field, $rownum = -1, $query_id = 0) + { + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + if($rownum > -1) + { + $result = @mysql_result($query_id, $rownum, $field); + } + else + { + if(empty($this->row[$query_id]) && empty($this->rowset[$query_id])) + { + if($this->sql_fetchrow()) + { + $result = $this->row[$query_id][$field]; + } + } + else + { + if($this->rowset[$query_id]) + { + $result = $this->rowset[$query_id][$field]; + } + else if($this->row[$query_id]) + { + $result = $this->row[$query_id][$field]; + } + } + } + return $result; + } + else + { + return false; + } + } + function sql_rowseek($rownum, $query_id = 0){ + if(!$query_id) + { + $query_id = $this->query_result; + } + if($query_id) + { + $result = @mysql_data_seek($query_id, $rownum); + return $result; + } + else + { + return false; + } + } + function sql_nextid(){ + if($this->db_connect_id) + { + $result = @mysql_insert_id($this->db_connect_id); + return $result; + } + else + { + return false; + } + } + function sql_freeresult($query_id = 0){ + if(!$query_id) + { + $query_id = $this->query_result; + } + + if ( $query_id ) + { + unset($this->row[$query_id]); + unset($this->rowset[$query_id]); + + @mysql_free_result($query_id); + + return true; + } + else + { + return false; + } + } + function sql_error($query_id = 0) + { + $result["message"] = @mysql_error($this->db_connect_id); + $result["code"] = @mysql_errno($this->db_connect_id); + + return $result; + } + +} // class sql_db + +} // if ... define + +?> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/.perms b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/.perms new file mode 100755 index 0000000..6c79fc3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/.perms @@ -0,0 +1,11 @@ +#!/bin/sh + +# Remove compiled files +rm -f templates/compiled/*.* + +find . -type f -exec chmod 644 {} \; +find . -type d -exec chmod 755 {} \; +find . \( -name '*.pl' -or -name '*.cgi' -or -name '.perms' -or -name '*.sh' \) -exec chmod a+x {} \; +find templates -maxdepth 1 -exec chmod a+wX {} \; + +chmod a+x .perms diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/MySQLMan.pm b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/MySQLMan.pm new file mode 100644 index 0000000..2b2c509 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/MySQLMan.pm @@ -0,0 +1,4356 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# MySQLMan +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: MySQLMan.pm,v 1.29 2009/04/25 03:14:33 brewt Exp $ +# +# Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Module wrapper to mysqlman functionality +# + +package MySQLMan; + +# ================================================================== + +use strict; +use vars qw($VERSION %CFG $DBH @ISA $IN @COOKIES ); + +use FindBin qw/$Bin/; + +$VERSION = '1.09'; + +@ISA = qw(GT::Base); + +# Required Librariers +# ----------------------------------------------------------------------------- +# Make sure we are using perl 5.003 and load other required files. +# +check_libraries(); + +sub new { +# ----------------------------------------------------------------------------- + my $class = shift; + my $bin = $Bin; + + # findbin sets the path to / sometimes if it can't + # find the cwd. + $bin ||= '.'; + $bin = '.' if $bin eq '/'; + + + $class->fatal("Arguments to new() must be a hash") + if @_ & 1; + my %opts = @_; + + $CFG{do} = delete $opts{do}; + $CFG{do} = 'do' unless defined $CFG{do}; + + $CFG{template_dont_save} = delete $opts{template_dont_save}; + $CFG{template_dont_save} = 1 unless defined $CFG{template_dont_save}; + +# FILES +# ----------------------------------------------------------------------------- +# the URL to mysql.cgi. +# You can set it as "mysql.cgi" to make it relative. + $CFG{script_url} = delete $opts{script_url}; + $CFG{script_url} = "mysql.cgi" unless defined $CFG{script_url}; + +# The URL to home/top. It is used for the link TOP on each page +# in the tool bar. + $CFG{home_url} = delete $opts{home_url}; + $CFG{home_url} = "/" unless defined $CFG{home_url}; + +# The PATH to the template directory. + $CFG{template_dir} = delete $opts{template_dir}; + $CFG{template_dir} = $bin . "/templates" + unless defined $CFG{template_dir}; + +# CONNECTION +# ----------------------------------------------------------------------------- +# Mysqlman allows user to skip the login page and connect +# to a database directly. (On = 1, Off = 0) + $CFG{direct_connect} = delete $opts{direct_connect}; + $CFG{direct_connect} = 0 unless defined $CFG{direct_connect}; + +# Database used. + $CFG{direct_db} = delete $opts{direct_db}; + $CFG{direct_db} = 'mysql' unless defined $CFG{direct_db}; + +# Host to connect to. + $CFG{direct_host} = delete $opts{direct_host}; + $CFG{direct_host} = 'localhost' unless defined $CFG{direct_host}; + +# Port. Standard port will be used if not specified. + $CFG{direct_port} = delete $opts{direct_port}; + $CFG{direct_port} = '' unless defined $CFG{direct_port}; + +# User name and password. + $CFG{direct_user} = delete $opts{direct_user}; + $CFG{direct_user} = 'root' unless defined $CFG{direct_user}; + $CFG{direct_pass} = delete $opts{direct_pass}; + $CFG{direct_pass} = '' unless defined $CFG{direct_pass}; + +# DISPLAY OPTION +# ----------------------------------------------------------------------------- +# Set the number of rows to be displayed in one page. + $CFG{page_length} = delete $opts{page_length}; + $CFG{page_length} = 20 unless defined $CFG{page_length}; + +# All tables displayed will be sorted by the column indicated +# here by default. (0 indicates the first column.) + $CFG{default_sort} = delete $opts{default_sort}; + $CFG{default_sort} = 0 unless defined $CFG{default_sort}; + +# Show 'NULL' when the cell is null? + $CFG{show_null} = delete $opts{show_null}; + $CFG{show_null} = 1 unless defined $CFG{show_null}; + +# Show columns with type TIMESTAMP in insert/edit form? + $CFG{show_timestamp_field} = delete $opts{show_timestamp_field}; + $CFG{show_timestamp_field} = 0 unless defined $CFG{show_timestamp_field}; + +# Prompt confirmation before deleting a single record? + $CFG{confirm_delete_record} = delete $opts{confirm_delete_record}; + $CFG{confirm_delete_record} = 1 unless defined $CFG{confirm_delete_record}; + +# INSERT RECORD OPTIONS +# ----------------------------------------------------------------------------- +# Would you like to be able to insert null values? If you turn +# this option off then all fields not filled will be treated as '' +# (blank). (Yes = 1, No = 0) + $CFG{insert_null} = delete $opts{insert_null}; + $CFG{insert_null} = 1 unless defined $CFG{insert_null}; + +# Where would you like to be brought to when you have done one insert? + $CFG{insert_origin} = delete $opts{insert_origin}; + $CFG{insert_origin} = 'insert' + unless defined $CFG{insert_origin}; #('tables' - to table list + # OR + # 'insert' - to insert new record page) + +# MYSQLDUMP +# ----------------------------------------------------------------------------- +# For very large databases, it might be a good idea to divide +# the contents of the tables into pages to be written into files +# to reduce the load on memory. +# (on = 1, off = 0) + $CFG{dump_in_pages} = delete $opts{dump_in_pages}; + $CFG{dump_in_pages} = 0 unless defined $CFG{dump_in_pages}; + +# The number of records to be written into the file at a time. + $CFG{dump_page_length} = delete $opts{dump_page_length}; + $CFG{dump_page_length} = 1000 unless defined $CFG{dump_page_length}; + +# MISC +# ----------------------------------------------------------------------------- +# Cookies used in the script + $CFG{db_host_cookie_name} = delete $opts{db_host_cookie_name}; + $CFG{db_host_cookie_name} = 'MySQLMan_host' + unless defined $CFG{db_host_cookie_name}; + $CFG{db_user_cookie_name} = delete $opts{db_user_cookie_name}; + $CFG{db_user_cookie_name} = 'MySQLMan_username' + unless defined $CFG{db_user_cookie_name}; + $CFG{db_pass_cookie_name} = delete $opts{db_pass_cookie_name}; + $CFG{db_pass_cookie_name} = 'MySQLMan_password' + unless defined $CFG{db_pass_cookie_name}; + $CFG{url_cookie_name} = delete $opts{url_cookie_name}; + $CFG{url_cookie_name} = 'MySQLMan_url' unless defined $CFG{url_cookie_name}; + + +# Set debug to 1 for debug. + $CFG{debug} = delete $opts{debug}; + $CFG{debug} = 0 unless defined $CFG{debug}; + + $class->fatal( "Unknown arguments to new(): " . join ', ', sort keys %opts ) + if keys %opts; + + my $c; + return bless \$c, $class; +} + +sub process { +# ----------------------------------------------------------------------------- + my $class = shift; + +# Initialize for mod_perl + $DBH = undef; + @COOKIES = (); + + $IN = GT::CGI->new; + + my $level; + if ( defined( $IN->param('db_user') ) || defined( $IN->param('db_host') ) ) + { + do_login(); + } + else { + $level = $IN->param( $CFG{do} ) || ''; + + if ( $level eq "logout" ) { + do_logout(); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return 1; + } + + if ( ( $level ne "login" ) && !$IN->param('form_login') ) { + assign_cookies() or return; # undef means user was redirected + } + + if ( $CFG{'direct_connect'} && !$IN->param ) { $level = 'tables'; } + + if ( !$level or $level eq 'show_dbs' ) { show_dbs(); } # Diplay the database list. + elsif ( $level eq "database" ) { + modify_db(); + } # Create or drop a database. + elsif ( $level eq "login" ) { + html_login(); + } # Prompt the log-in page when needed. + elsif ( $level eq "tables" ) { + show_tables(); + } # Display the list of tables. + elsif ( $level eq "browse" ) { + table_browse(); + } # Do a general browse. + elsif ( $level eq "select" ) { + table_select(); + } # Compose query criteria for browse. + elsif ( $level eq "insert" ) { + html_insert(); + } # Input value for insert. + elsif ( $level eq "insert_record" ) { + insert_record(); + } # Insert the value input into table. + elsif ( $level eq "property" ) { + table_property(); + } # Display column spec's of the current table. + elsif ( $level eq "modify" ) { + table_modify(); + } # Modify the table contents. + elsif ( $level eq "create" ) { + html_table_def( 'create' ); + } # Construct the specifications of the new table. + elsif ( $level eq "create_table" ) { + create_table(); + } # Create a new table according to the specification. + elsif ( $level eq "alter_table" ) { + alter_table(); + } # Change the structure of a table. + elsif ( $level eq "add_col" ) { + html_table_def( 'add_col' ); + } # Add new column(s) to a table. + elsif ( $level eq "sql_monitor" ) { + sql_monitor(); + } # Process query entered in SQL Monitor. + elsif ( $level eq "sql_monitor_file" ) { + sql_monitor_file(); + } # Process queries saved in a file. + elsif ( $level eq "import" ) { + import_record(); + } # Do import from file. + elsif ( $level eq "export" ) { + export_record(); + } # Do export to file. + elsif ( $level eq "mysqldump" ) { + mysqldump(); + } # Create a table dump into file specified. + elsif ( $level eq "top_level_op" ) { + top_level_op(); + } # Create db/create table/SQL Monitor/import/export/ + # add fields/rename table. + elsif ( $level eq "show_query" ) { + html_show_query(); + } # display saved query in SQL monitor. + elsif ( $level eq "save_search" ) { html_save_search(); } + elsif ( $level eq "help" ) { + html_help(); + } # display help pages + else { + cgierr("fatal error: $@"); + } # Display error message if error occurs. + + if ($DBH) { $DBH->disconnect; } + } + if ( $CFG{'debug'} ) { cgierr("debug"); } + %CFG = (); + return 1; +} + +sub show_dbs { +# ----------------------------------------------------------------------------- +# Diplays all the databases in MySQL. The function will +# take the output of SHOW DATABASES query and list all +# the databases in MySQL. Each name is a link to the table +# list of the database and a "Drop" link is also created here +# with each database for easy management. + + my ( $feedback ) = @_; + + if ( !$DBH ) { connect_db() or return; } + my $query = "SHOW DATABASES"; + my $sth = exec_query($query) or return; + + my $database_list = []; + + while ( my ($db) = $sth->fetchrow_array ) { + push @$database_list, { name => $db }; + } + $sth->finish; + + html_database( undef, $database_list, $feedback ) or return; +} + +#=================================================# +# DATABASE MANAGEMENT # +#=================================================# + +sub modify_db { +# ----------------------------------------------------------------------------- +# Then function will determine whether to create a new +# database or drop a existing one. +# + my $action = $IN->param('action') || ''; + + if ( $action eq 'drop_db' ) { drop_db(); } + elsif ( $action eq 'create_db' ) { create_db(); } + else { cgierr("database modify action cannot be identified."); } +} + +sub drop_db { +# ----------------------------------------------------------------------------- +# Here a "DROP DATABASE db_name" query is executed. If +# the confirmed flag is not on then the user will be brought +# to a confirmation page. If the action is confirmed, the +# database specified will be dropped and the user will be brought +# back to the database list page. +# It is disabled in demo mode. + + + my $db = $IN->param('db') || ''; + + my ( $query, $sth ); + + $query = "DROP DATABASE $db"; + + if ( $IN->param('comfirmed') ) { + + + if ( !$DBH ) { connect_db() or return; } + $sth = exec_query($query) or return; + $sth->finish; + my $message = "Database $db Dropped."; + show_dbs( $message ); + } + else { html_confirm_action( $query ); } +} + +sub create_db { +# ----------------------------------------------------------------------------- +# Before a new database is created, the name specified will +# be tested to see if it is a valid one. If it is, then the +# table will be created and the user will be brought back to the +# database list. +# It is disabled in demo mode. + + + my $db = $IN->param('db') || ''; + + my ( $query, $sth ); + valid_name_check($db) or return; + + + if ( !$DBH ) { connect_db() or return; } + $query = "CREATE DATABASE $db"; + $sth = exec_query($query) or return; + $sth->finish; + + my $message = "New Database $db Created"; + show_dbs( $message ); +} + +#=================================================# +# TABLE MANAGEMENT # +#=================================================# + +# ================= # +# Table Display # +# ================= # + +sub show_tables { +# ----------------------------------------------------------------------------- +# Shows all the tables in the database chosen. Browse/Select +# /Properties/Insert/Drop/Empty links are also created with +# each table name. + + my ( $feedback ) = @_; + my ( $query, $sth, $table ); + my $data_source = $IN->param("data_source") || ''; + + if ( !$DBH ) { connect_db() or return; } + $query = "show tables"; + $sth = exec_query($query) or return; + + my @tables; + while ( ($table) = $sth->fetchrow_array() ) { + push @tables, { + name => $table, + count => record_count($table) + }; + } + $sth->finish; + html_table( \@tables, $feedback ); +} + +# ======================= # +# Table Browse/Select # +# ======================= # + +sub table_browse { +# ----------------------------------------------------------------------------- +# Browse, Select/Search +# +# The function does a "SELECT * FROM table_name" query +# to do a browse and will display the results according to +# the select criteria specified by user in "select". If a +# primary key exists in the table, then "edit" and "drop" links +# are also created with each record. +# +# SQL-Monitor +# +# A query entered in SQL monitor that requires +# displaying it's result uses this sub-routine as well. +# These queries include explain, select, describe, and desc. + + my ( $query ) = @_; + my ( + $where_clause, $start_row, $empty_set, @pri_key, + $prep, $sth, @cols, $rows, + @ary, $index, $col_name, $table_records, + $record, $cells, $page_jump, $page_link, + $rows_in_page, @fields, @example, @record_modify, + $record_modify, $edit_link, @table_list, $table_num, + $pri_key_count, $pri_key, $query_printed, $query_count, + $total_rec_num + ); + + my $data_source = $IN->param("data_source") || ''; + my $table = $IN->param("table") || ''; + my $page = $IN->param("page") || "1"; + my $action = $IN->param("browse_action") || $IN->param("action") || ''; + my $fields = $IN->param("fields") || ''; + my $where = $IN->param("where") || ''; + my $example = $IN->param("example") || ''; + + + if ( ( $page =~ m/\D/ ) ) { + sqlerr("Page number cannot be $page. Please enter a valid page number."); + return; + } + +# The first row of the page arrived. + $start_row = ( ( $page - 1 ) * $CFG{'page_length'} ); + + if ( !$DBH ) { connect_db() or return; } + +# get all column names for the table and store them in @cols. + if ( $action eq 'browse' || $action eq 'select' ) { + @cols = get_cols( $table ); + } + + if ( $action eq 'browse' ) { + $fields = '*'; + $index = $IN->param("sort_index") || $cols[ $CFG{'sort_default'} ]; + } + elsif ( $action eq 'select' ) { + +# SELECT clause. + if ( !$fields ) { + + @fields = (); + for ( my $i = 0 ; $i <= $#cols ; $i++ ) { + if ( $IN->param("*select_field*_$cols[$i]") ne '' ) { + push ( @fields, $IN->param("*select_field*_$cols[$i]") ); + } + } + $fields = join ",", @fields; + } + +# WHERE clause. + if ($where) { $where_clause = "WHERE $where"; } + +# Query by example. + if ( !$example ) { + @example = (); + for ( my $i = 0 ; $i <= $#cols ; $i++ ) { + if ( $IN->param("*example*_$cols[$i]") ne '' ) { + my $temp = + $cols[$i] . ' like ' + . $DBH->quote( $IN->param("*example*_$cols[$i]") ); + push ( @example, $temp ); + } + } + $example = join " and ", @example; + } + + if ($example) { + if ($where_clause) { $where_clause .= " and $example"; } + else { $where_clause = "WHERE $example"; } + } + +# get sort index + $query = qq~SELECT $fields + FROM $table + $where_clause + LIMIT 1~; + + $prep = exec_query($query) or return; + $index = $IN->param("sort_index") + || $prep->{NAME}->[ $CFG{'sort_default'} ]; + $prep->finish; + } + + @pri_key = (); + $pri_key = ''; + + if ( $action eq 'browse' || $action eq 'select' ) { + +# Prepare the contents in the table selected. + + @pri_key = get_pri_key($table); + $pri_key = join ",", @pri_key; + + if ( $pri_key ne '' ) { $pri_key = ',' . $pri_key; } + +# the actual query sent to statement handler. The +# primary key is selected for delete and edit. + $query = qq~SELECT $fields $pri_key + FROM $table + $where_clause + ORDER BY $index + LIMIT $start_row, $CFG{'page_length'}~; + +# The query that gets printed in SQL-Message. + $query_printed = qq~SELECT $fields + FROM $table + $where_clause + ORDER BY $index + LIMIT $start_row, $CFG{'page_length'}~; + +# counts the total number of resulting records from browse/select + $query_count = qq~SELECT COUNT(*) + FROM $table + $where_clause~; + $sth = exec_query($query_count) or return; + ($total_rec_num) = $sth->fetchrow; + $sth->finish; + } + else { # from SQL Monitor. + + if ( !$query ) { $query = $IN->param("query") || ''; } + @table_list = get_table_list($query); + if ( $#table_list == 0 ) { ($table) = @table_list; } + } + +# Get all records or records that satisfy the search criteria. +# Or, $query is simply the query enter in SQL monitor. + $sth = exec_query($query) or return; + $rows = $sth->rows; + + if ( $action eq 'monitor' ) { + $total_rec_num = $rows; + $rows_in_page = $rows - $start_row; + if ( $rows_in_page > $CFG{'page_length'} ) { + $rows_in_page = $CFG{'page_length'}; + } + } + else { $rows_in_page = $rows; } + + $page_jump = + link_page_jump( $fields, $example, $index, $total_rec_num ); + +# Links to next/previous/top page if there is any. + $page_link = link_page( $rows_in_page, $table, $fields, $example, $index, $total_rec_num ); + + my $example_esc = $IN->escape($example); + my $where_esc = $IN->escape($where); + my $query_esc = $IN->escape($query); + + if (@pri_key) { $pri_key_count = $#pri_key + 1; } + else { $pri_key_count = 0; } + +# Display column names + $col_name = []; + if ( $action eq 'browse' || $action eq 'select' ) { + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} - $pri_key_count ; $i++ ) { + push @$col_name, { + name => $sth->{NAME}->[$i], + link => qq~\n$CFG{'script_url'}?$CFG{do}=browse&data_source=$data_source&table=$table&page=$page&sort_index=$sth->{NAME}->[$i]&action=$action&fields=$fields&where=$where_esc&example=$example_esc&query=$query_esc~ + }; + } + } + else { + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} - $pri_key_count ; $i++ ) { + push @$col_name, { name => $sth->{NAME}->[$i] }; + } + } + + $example_esc = $IN->html_escape($example); + $where_esc = $IN->html_escape($where); + $query_esc = $IN->html_escape($query); + +# Display the contents in the table selected. + $table_records = []; + my $counter = 0; + +# Display the resulting set of records. The result is divided into pages and the page +# by the length specified in mysql.cfg. +# +# From "Browse" or "Select/Search" +# The LIMIT clause of the query limits the records to display, so we don't display all. +# From "SQL Monitor" +# Records between $start_row and $start_row+$CFG{'page_length'} will be displayed. +# + while ( @ary = $sth->fetchrow_array() ) { + if ( + $action ne 'monitor' + || ( $counter >= $start_row + && $counter < ( $CFG{'page_length'} + $start_row ) ) + ) + { + $record = []; + @record_modify = (); + + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} ; $i++ ) { + if ( $i < $sth->{NUM_OF_FIELDS} - $pri_key_count ) { + + $ary[$i] = $IN->html_escape( $ary[$i] ); + $ary[$i] =~ s/(\r|\n)+/
        /g; + $ary[$i] =~ s/\t+/   /g; + $ary[$i] =~ s/\s+/ /g; + $ary[$i] =~ s/<BR>/<BR>\n/g; + + push @$record, { + name => \$ary[$i], + null => !defined($ary[$i]) + }; + } + +# if there are any primary keys, then push "pri = value" +# into @record_modify. + else { + my $cell = $ary[$i]; + $cell = $DBH->quote($cell); + my $col_name = $sth->{NAME}->[$i]; + push ( @record_modify, $col_name . ' = ' . $cell ); + } + } + if (@pri_key && ($action ne 'monitor')) { + $record_modify = join ' and ', @record_modify; + my $link = + $CFG{script_url} . + "?$CFG{do}=modify" . + ";data_source=" . $IN->escape($data_source) . + ";table=" . $IN->escape($table) . + ";page=" . $IN->escape($page) . + ";sort_index=" . $IN->escape($index) . + ";fields=" . $IN->escape($fields) . + ";where=" . $IN->escape($where) . + ";example=" . $IN->escape($example) . + ";record_modify=" . $IN->escape($record_modify) . + ";browse_action=" . $IN->escape($action); + my $edit_link = $link . ";action=edit_record"; + my $delete_link = $link . ";action=delete_record"; + push @$table_records, { + record => $record, + edit_link => \$edit_link, + delete_link => \$delete_link + }; + } + else { + push @$table_records, { record => $record }; + } + } + $counter++; + } + if ( !@$table_records ) { $empty_set = 1; } + else { $empty_set = 0; } + + $sth->finish; + + my $save_search_link = "$CFG{script_url}?$CFG{do}=save_search;data_source=" . $IN->escape($data_source) . ";table=" . $IN->escape($table) . ";page=" . $IN->escape($page) . ";sort_index=" . $IN->escape($index) . ";fields=" . $IN->escape($fields) . ";where=" . $IN->escape($where) . ";example=" . $IN->escape($example) . ";action=edit_record;record_modify=" . $IN->escape($record_modify) . ";browse_action=" . $IN->escape($action) . ";query=" . $IN->escape($query); + + html_display( + 'table_browse.html', + { + total_rows => $total_rec_num, + table => $table, + page => scalar $IN->param('page') || '1', + empty_set => $empty_set, + page_jump => \$page_jump, + show_null => $CFG{show_null}, + page_link => \$page_link, + col_name => $col_name, + col_num => scalar(@$col_name), + table_records => $table_records, + query => $query, + query_printed => $query_printed || $query, + pri_key => $pri_key, + help_topic => "browse", + save_search_link => \$save_search_link, + fields => $fields, + where_esc => \$where_esc, + example_esc => \$example_esc, + query_esc => \$query_esc, + confirm_delete_record => $CFG{confirm_delete_record}, + } + ); +} + +sub table_select { +# ----------------------------------------------------------------------------- +# This function creates the search form for a SELECT... query (search). +# Field names are in check boxes and "query by example" input +# fields are created with the check boxes. + + + my ( $query, $select_table, $example_table, @type_ary, @cols ); + + my $data_source = $IN->param("data_source") || ''; + my $table = $IN->param("table") || ''; + my $page = $IN->param("page") || 1; + + $select_table = []; + $example_table = []; + + + if ( !$DBH ) { connect_db() or return; } + +# Get the names of the all columns. + @cols = get_cols( $table ); + +# fields selection (for SELECT) + @type_ary = get_col_type($table); + + for (my $i = 0; $i < @cols; $i++) { + push @$select_table, { name => $cols[$i] }; + push @$example_table, { + name => $cols[$i], + type => $type_ary[$i] + }; + + } + + html_display( + 'table_select.html', + { + select_table => $select_table, + select_table_cnt => scalar(@$select_table), + example_table => $example_table, + example_table_cnt => scalar(@$example_table), + help_topic => "select", + } + ); +} + +sub table_property { +# ----------------------------------------------------------------------------- +# The function outputs the result of "describe table_name" +# query. It reads the output row by row and create +# Change/Drop/Primary/Index/Unique links with each field. + + my ( $feedback ) = @_; + my ( $page, $query, $sth, @ary, $table_property ); + + my $data_source = $IN->param("data_source") || ''; + my $table = $IN->param("table") || ''; + + + if ( !$DBH ) { connect_db() or return; } + $query = "describe $table"; + $sth = exec_query($query) or return; + my $columns = [ map {; { name => $_ } } @{$sth->{NAME}} ]; + +# Display the contents in the table selected. + $table_property = []; + while ( @ary = $sth->fetchrow_array() ) { + push @$table_property, { + columns => [ map {; { name => $_ } } @ary ], + change_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&col=$ary[0]&action=alter_col~, + drop_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&col=$ary[0]&action=drop_col~, + primary_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&col=$ary[0]&action=set_primary~, + index_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&col=$ary[0]&action=set_index~, + unique_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&col=$ary[0]&action=set_unique~ + }; + } + $sth->finish; + + my $key_table = get_key_table(); + html_display( + 'property.html', + { + table_property => $table_property, + table_property_cnt => scalar(@$table_property), + table_columns => $columns, + table_columns_cnt => scalar(@$columns), + key_table => $key_table, + key_table_cnt => scalar(@$key_table), + feedback => $feedback, + help_topic => "properties", + } + ); +} + +# ===================== # +# Insert New Record # +# ===================== # + +sub insert_record { +# ----------------------------------------------------------------------------- +# This function insert a new record into the table specified. + + + my $table = $IN->param('table') || ''; + my $feedback; + my ( $query, $sth, @insert_info, $new_record, @insert_fields, $fields, + @insert_values, $values ); + + + if ( !$DBH ) { connect_db() or return; } + +# Get the info of the new record to be inserted. + @insert_info = compose_new_condition( 1 ); + + my $counter = 0; + foreach my $element (@insert_info) { + + my $is_value = $counter % 2; + + if ($is_value) { # Get the values + push ( @insert_values, $element ); + } + else { # Get the name of the fields + push ( @insert_fields, $element ); + } + $counter++; + } + +# Make the input from the form into a string to fit in the query. + $fields = join ",", @insert_fields; + $values = join ",", @insert_values; + + $query = "INSERT INTO $table ($fields) VALUES ($values)"; + $sth = exec_query($query) or return; + $sth->finish; + + $feedback = 'Record Inserted.'; + if ( $CFG{'insert_origin'} eq 'table' ) { show_tables( $feedback ); } + else { html_insert( $feedback ) } +} + +# ====================== # +# Create New Table # +# ====================== # + +sub create_table { +# ----------------------------------------------------------------------------- +# This function takes in the input from the create table +# form and put them together to produce a create table +# query. + + + my $table = $IN->param('table') || ''; + my ( + @field_list, $col_spec, @primary_list, @index_list, + @unique_list, $fields, $primary, $index, + $unique, $sth, $query + ); + + + if ( !$DBH ) { connect_db() or return; } + +# get the specification of each column. + for ( my $i = 0 ; $i < $IN->param('num_of_fields') ; $i++ ) { + +# Make the text input fields into a string to fit in the query. + $col_spec = concate_col_spec( $i ); + + push ( @field_list, "$col_spec" ); + +# Check index fields. + if ( $IN->param("primary_$i") ) { + push ( @primary_list, $IN->param("field_$i") ); + } + if ( $IN->param("index_$i") ) { + push ( @index_list, $IN->param("field_$i") ); + } + if ( $IN->param("unique_$i") ) { + push ( @unique_list, $IN->param("field_$i") ); + } + } + + $fields = join ",", @field_list; + $primary = join ",", @primary_list; + $index = join ",", @index_list; + $unique = join ",", @unique_list; + + $query = "CREATE TABLE $table($fields"; + + if ($primary) { $query .= ", PRIMARY KEY ($primary)" } + if ($index) { $query .= ", INDEX ($index)" } + if ($unique) { $query .= ", UNIQUE ($unique)" } + + $query .= ')'; + + $sth = exec_query($query) or return; + $sth->finish; + + show_tables( "Table $table Created." ); +} + +# ====================== # +# Table Modification # +# ====================== # + +sub table_modify { +# ----------------------------------------------------------------------------- +# Determine modify action. +# + my $action = $IN->param('action') || ''; + + if ( $action eq 'drop_table' ) { drop_table(); } + elsif ( $action eq 'empty_table' ) { empty_table(); } + elsif ( $action eq 'delete_record' ) { delete_record(); } + elsif ( $action eq 'edit_record' ) { edit_record_html(); } + elsif ( $action eq 'update' ) { update_record() } + else { cgierr("modify action cannot be identified"); } +} + +sub drop_table { +# ----------------------------------------------------------------------------- +# The function drops the table specified if the confirmed +# flag is on. + + + my $table = $IN->param('table') || ''; + my ( $query, $sth ); + + + $query = "DROP TABLE $table"; + + if ( $IN->param('comfirmed') ) { + if ( !$DBH ) { connect_db() or return; } + $sth = exec_query($query) or return; + show_tables( "Table $table dropped!" ); + } + else { html_confirm_action( $query ); } +} + +sub empty_table { +# ----------------------------------------------------------------------------- +# The function deletes all the records in the table specified +# if the confirmed flag is on. + + + my ( $table, $query, $sth ); + + $table = $IN->param('table') || ''; + + + $query = "DELETE FROM $table"; + + if ( $IN->param('comfirmed') ) { + if ( !$DBH ) { connect_db() or return; } + $sth = exec_query($query) or return; + show_tables( "Table $table emptied!" ); + } + else { html_confirm_action( $query ); } +} + +sub delete_record { +# ----------------------------------------------------------------------------- +# Delete a single record in the table selected. +# $record_modify consists the primary key(s) value of +# the record being deleted. +# + my $table = $IN->param('table') || ''; + my $record_modify = $IN->param('record_modify') || ''; + my ( $sth, $query ); + + + if ( !$DBH ) { connect_db() or return; } + $query = "DELETE FROM $table WHERE $record_modify LIMIT 1"; + $sth = exec_query($query) or return; + $sth->finish; + + table_browse(); +} + +sub edit_record_html { +# ----------------------------------------------------------------------------- +# Pre-processing stage before the edit record form is +# displayed. This function prepares necessary information +# for the edit form. +# $record_modify consists the primary key(s) +# value of the record being edited. +# i.e. key = value. +# + my $table = $IN->param('table') || ''; + my $record_modify = $IN->param('record_modify') || ''; + my ( $sth, $query, @record, $update, $update_fields, $form_hidden ); + + + if ( !$DBH ) { connect_db() or return; } + +# Get the record being modified. + $query = "SELECT * FROM $table WHERE $record_modify"; + $sth = exec_query($query) or return; + @record = $sth->fetchrow_array; + my $row = $sth->rows; + $sth->finish; + +# create the the edit record form table. + ($update_fields, $form_hidden) = form_fields( 1, @record ); + html_update( $update_fields, $form_hidden ); +} + +sub update_record { +# ----------------------------------------------------------------------------- +# Take in the input from the edit table form and update +# the record specified. +# + my $table = $IN->param('table') || ''; + my $record_modify = $IN->param('record_modify') || ''; + my ( $sth, $query, $update, @fields ); + + + if ( !$DBH ) { connect_db() or return; } + +# Get the updated values in each field. Each element in the +# field is in the form "field = value". + @fields = compose_new_condition(); + + $update = join ",", @fields; + $query = "UPDATE $table SET $update WHERE $record_modify"; + $sth = exec_query($query) or return; + $sth->finish; + + table_browse(); +} + +# ====================== # +# Table Alteration # +# ====================== # + +sub alter_table { +# ----------------------------------------------------------------------------- +# Identify alter table action. +# + my $action = $IN->param('action') || ''; + + if ( $action eq 'alter_col' ) { alter_col_html(); } + elsif ( $action eq 'do_alter_col' ) { alter_col(); } + elsif ( $action eq 'drop_col' ) { drop_col(); } + elsif ( $action eq 'set_primary' ) { set_primary(); } + elsif ( $action eq 'set_index' ) { set_index(); } + elsif ( $action eq 'set_unique' ) { set_unique(); } + elsif ( $action eq 'drop_key' ) { drop_key(); } + elsif ( $action eq 'add_col' ) { add_col(); } + elsif ( $action eq 'rename_table' ) { rename_table(); } + else { cgierr("Alter Table action cannot be identified"); } +} + +sub alter_col_html { +# ----------------------------------------------------------------------------- +# The function first reads in the spec's of the column +# chosen in the current table. Then the type/length_set +# /attribute is identified individually. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + + my ( $field, $type, $null, $key, $default, $extra ); + my ( $sth, $query, $length_set, $attributes, $dump, $type_name ); + + +# Get column specification. + if ( !$DBH ) { connect_db() or return; } + $col = $DBH->quote($col); + $query = "SHOW COLUMNS FROM $table LIKE $col"; + $sth = exec_query($query) or return; + +# parse column definition. + my @ary = $sth->fetchrow_array; + ( + $field, $type_name, $length_set, $attributes, $null, $key, $default, + $extra + ) + = parse_col_spec(@ary); + $sth->finish; + + html_alter_col( $field, $type_name, $length_set, $attributes, $null, $default, $extra ); +} + +sub alter_col { +# ----------------------------------------------------------------------------- +# Updates the column specification. The input from the +# alter column is taken in and made into a string to be +# fit as part of the query string. Then the user is +# brought back to the property page. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + my ( $col_spec, $sth, $query ); + + + if ( !$DBH ) { connect_db() or return; } + +# Get the updated column specs in string format. + $col_spec = concate_col_spec( 0 ); + + $query = "ALTER TABLE $table CHANGE $col $col_spec"; + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Specification of Column $col of Table $table Has Been Changed." ); +} + +sub drop_col { +# ----------------------------------------------------------------------------- +# The function drops the column/field specified +# if the confirmed flag is on. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + my ( $col_spec, $sth, $query ); + + + $query = "ALTER TABLE $table DROP $col"; + + if ( $IN->param('comfirmed') ) { + if ( !$DBH ) { connect_db() or return; } + $sth = exec_query($query) or return; + $sth->finish; + table_property( "Column $col of Table $table Has Been Dropped." ); + } + else { html_confirm_action( $query ); } +} + +sub set_primary { +# ----------------------------------------------------------------------------- +# The function will first set the column not nullable +# and then set the column as primary key. Note that an +# error will occur if all there already exists a primary key. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + my ( $sth, $query ); + + + if ( !$DBH ) { connect_db() or return; } + $query = "ALTER TABLE $table ADD PRIMARY KEY ($col)"; + +# Set the column not nullable + set_col_not_null(); + + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Column $col set as primary key." ); +} + +sub set_index { +# ----------------------------------------------------------------------------- +# The function will first set the column not nullable +# and then set the column as index. Note that an +# error will occur if all there already exists a primary key. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + my ( $sth, $query ); + + + $query = "ALTER TABLE $table ADD INDEX ($col)"; + + if ( !$DBH ) { connect_db() or return; } + +# Set the column not nullable. + set_col_not_null(); + + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Column $col set as index." ); +} + +sub set_unique { +# ----------------------------------------------------------------------------- +# The function will first set the column not nullable +# and then set the column as unique. Note that an +# error will occur if all there already exists a primary key. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + my ( $sth, $query ); + + + $query = "ALTER TABLE $table ADD UNIQUE ($col)"; + + if ( !$DBH ) { connect_db() or return; } + +# Set the column not nullable. + set_col_not_null(); + + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Column $col set as unique." ); +} + +sub drop_key { +# ----------------------------------------------------------------------------- +# Drops the key specified. +# + my $table = $IN->param('table') || ''; + my $key_name = $IN->param('key_name') || ''; + my ( $sth, $query ); + + + if ( $key_name eq 'PRIMARY' ) { + $query = "ALTER TABLE $table DROP PRIMARY KEY"; + } + else { $query = "ALTER TABLE $table DROP INDEX $key_name"; } + + if ( !$DBH ) { connect_db() or return; } + $sth = exec_query($query) or return; + $sth->finish; + + if ( $key_name eq 'PRIMARY' ) { + table_property( "Primary Key of Table $table Has Been Dropped." ); + } + else { + table_property( "Index $key_name of Table $table Has Been Dropped." ); + } +} + +sub add_col { +# ----------------------------------------------------------------------------- +# Adds new columns to the table specified. +# + my $table = $IN->param('table') || ''; + my $position = $IN->param('position') || ''; + my ( + @field_list, $col_spec, @primary_list, @index_list, + @unique_list, $fields, $primary, $index, + $unique, $sth, $query + ); + + + if ( !$DBH ) { connect_db() or return; } + + for ( my $i = 0 ; $i < $IN->param('num_of_fields') ; $i++ ) { + + $col_spec = 'ADD ' . concate_col_spec( $i ) . " $position"; + push ( @field_list, "$col_spec" ); + + if ( $IN->param("primary_$i") ) { + push ( @primary_list, $IN->param("field_$i") ); + } + if ( $IN->param("index_$i") ) { + push ( @index_list, $IN->param("field_$i") ); + } + if ( $IN->param("unique_$i") ) { + push ( @unique_list, $IN->param("field_$i") ); + } + + $position = "After " . $IN->param("field_$i"); + } + +# elements in @field_list are in the form "ADD field_name field_spec". + $fields = join ",", @field_list; + $primary = join ",", @primary_list; + $index = join ",", @index_list; + $unique = join ",", @unique_list; + + $query = "ALTER TABLE $table $fields"; + + if ($primary) { $query .= ", ADD PRIMARY KEY ($primary)" } + if ($index) { $query .= ", ADD INDEX ($index)" } + if ($unique) { $query .= ", ADD UNIQUE ($unique)" } + + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Column(s) added to Table $table" ); +} + +sub rename_table { +# ----------------------------------------------------------------------------- +# Renames the table chosen to a new name specified. +# The name entered will be checked to see if it is a +# valid one. If it is, then the table will be renamed +# and the user will be brought back to the table property +# page. +# + my $new_name = $IN->param('table') || ''; + my $old_table = $IN->param('old_table') || ''; + my ( $query, $sth, @name ); + + valid_name_check( $IN->param('table') ) or return; + + + if ( !$DBH ) { connect_db() or return; } + $query = "ALTER TABLE $old_table RENAME AS $new_name"; + $sth = exec_query($query) or return; + $sth->finish; + + table_property( "Table $old_table Renamed to $new_name." ); +} + +#=================================================# +# Top Level Operations # +#=================================================# + +sub top_level_op { +# ----------------------------------------------------------------------------- +# Determine which top level operation page to display. + + + my $action = $IN->param('action') || ''; + if ( $action eq 'create_db' ) { html_create_db() } + elsif ( $action eq 'sql_monitor' ) { html_sql_monitor() } + elsif ( $action eq 'create_table' ) { html_create_table() } + elsif ( $action eq 'import' ) { html_import( table_field_prep() ) } + elsif ( $action eq 'export' ) { html_export( table_field_prep() ) } + elsif ( $action eq 'add_fields' ) { html_add_fields() } + elsif ( $action eq 'rename_table' ) { html_rename_table() } + elsif ( $action eq 'mysqldump' ) { html_mysqldump() } + else { cgierr("Action cannot be identified in top level operation.") } +} + +#=================================================# +# SQL Monitor # +#=================================================# + +sub sql_monitor { +# ----------------------------------------------------------------------------- +# The monitor will be enabled when a database is selected +# from the database list page. It will take in the input +# from the text box and send it to mysql. The query will +# first be determined if it is of a "browse" one. If it is, +# the result will be displayed using &table_browse. +# It is disabled in demo mode. +# + my $queries = $IN->param('query') || ''; + + if ( $IN->param('from_saved_queries') ) { + $queries = get_pre_query() || return sqlerr("No query specified."); + } + + my ( @query, @lines, $query, $command, $sth, $rows, $message ); + my $query_no = 0; + + +# What type of queries prompt a browse mode. + my %browse_cmd = ( + explain => 1, + select => 1, + show => 1, + describe => 1, + desc => 1, + ); + + if ( !$IN->param('save_query') ) { + + @lines = split /[\n\r]/, $queries; + + for ( my $i = 0 ; $i <= $#lines ; $i++ ) { + +# strips out the beginning and ending spaces. + $lines[$i] =~ s/^\s+//; + $lines[$i] =~ s/\s+$//; + + if ( !( $lines[$i] =~ /^#/ ) ) { + + if ( ( $lines[$i] =~ /;\s*$/ ) or ( $i == $#lines ) ) { + + $lines[$i] =~ s/\s*;\s*$//; + $query .= "$lines[$i]"; + $query =~ s/^\s+//; + $query =~ s/\s+$//; + + if ( $query ne '' ) { + @query = split / /, $query; + $command = lc( $query[0] ); + +# display the result if the query of a browse one. +# else execute the query and return the number of +# rows affect. + + if ( $browse_cmd{$command} ) { + return table_browse( $query ); + } + else { + if ( !$DBH ) { connect_db() or return; } + $rows = $DBH->do($query) + or + return sqlerr(\( GT::CGI->html_escape( $DBI::errstr ) . ".

        Query: " . GT::CGI->html_escape( $query ) ) ); + $rows += 0; + $message = "$rows row(s) affected"; + } + $query_no++; + $query = ''; + } + } + else { + $query .= " $lines[$i]"; + } + } + } + if ( $query_no > 1 ) { $message = 'Queries executed successfully.' } + return html_sql_monitor( $message ); + } +} + +sub sql_monitor_file { +# ----------------------------------------------------------------------------- +# Does the same thing as sub sql_monitor only that the +# queries are read from a file. The functions first checkes +# if a server file path is entered. If not, then it will look +# for the file uploaded to the temp directory from local drive. +# + my $file = $IN->param('server_file'); + my ($data); + + my $query = ''; + + if ( !$file ) { $file = create_temp_file() or return; } + + + if ( !$DBH ) { connect_db() or return; } + + open QF, "<$file" or cgierr("Cannot open query file '$file': $!"); + while ( defined( my $line = ) ) { + + my $isComment = 0; + my $isBlankLine = 0; + + if ( $line =~ /^\s*#/ ) { $isComment = 1 } + if ( $line =~ /^\s*\n/ ) { $isBlankLine = 1 } + if ( !$isComment and !$isBlankLine ) { $query .= " $line"; } + + if ( $line =~ /;\s*(\n|$)/ ) { + + if ( !$DBH ) { connect_db() or return; } + +# strips out the beginning and ending spaces. + $query =~ s/^\s+//; + $query =~ s/\s+$//; + $query =~ s/(\r|\n)+/ /g; + + if ( $query ne ';' ) { + +# run query. + $DBH->do($query) + or return sqlerr(\(GT::CGI->html_escape($DBI::errstr) . ".

        Query: " . GT::CGI->html_escape($query))); + } + +# clean up query and prepare to take in the next one. + $query = ''; + } + } + close QF; + if ( $IN->param('upload_local_file') && !$IN->param('server_file') ) { + unlink $file; + } + +# In case the last query does not end with a semi-colon. + $query =~ s/^\s+//; + $query =~ s/\s+$//; + $query =~ s/(\r|\n)+/ /g; + + if ( !( $query =~ /;$/ ) and ( $query ne '' ) ) { + +# run query. + $DBH->do($query) or return sqlerr(\(GT::CGI->html_escape($DBI::errstr) . ".

        Query: " . GT::CGI->html_escape($query))); + } + + html_sql_monitor( "Queries executed successfully." ); +} + +#=================================================# +# Import / Export # +#=================================================# + +sub import_record { +# ----------------------------------------------------------------------------- +# Import records to the table specified from a delimited +# text file. +# It is disabled in demo mode. +# + my $delimiter = + defined( $IN->param('delimiter') ) ? $IN->param('delimiter') : ''; + my $rec_del = defined( $IN->param('rec_del') ) ? $IN->param('rec_del') : ''; + my $table = $IN->param('table') || ''; + my $file = $IN->param('server_file') || ''; + my $import_all_cols = $IN->param('import_all_cols') || ''; + my $local = $IN->param('local') || ''; + my $replace_op = $IN->param('replace_op') || ''; + my $replace_act = $IN->param('replace_act') || ''; + my $escape_char = + defined( $IN->param('escape_char') ) ? $IN->param('escape_char') : ''; + my $ignore_line = $IN->param('ignore_line') || 0; + + my @select_fields = $IN->param('ImportRight'); + + my ( $query, $sth, $file_q, $delimiter_q, $rec_del_q, $escape_char_q, + $field_op ); + + + if ( !$DBH ) { connect_db() or return; } + + if ( !$file ) { + $file = create_temp_file() or return; + } + +# quote the inputs + $file_q = $DBH->quote($file); + $delimiter_q = "'" . $delimiter . "'"; + $rec_del_q = "'" . $rec_del . "'"; + $escape_char_q = $DBH->quote($escape_char); + + if ( !$replace_op ) { $replace_act = ''; } + + $query = qq~LOAD DATA $local INFILE $file_q $replace_act + INTO TABLE $table + FIELDS + TERMINATED BY $delimiter_q + ESCAPED BY $escape_char_q + LINES TERMINATED BY $rec_del_q + IGNORE $ignore_line LINES~; + + if ( !$import_all_cols ) { # import selected fields only. + my $selected_cols = "(" . join ( ",", @select_fields ) . ")"; + $query .= " $selected_cols"; + } + + $sth = exec_query($query) or return; + $sth->finish; + + if ( $IN->param('upload_local_file') && !$IN->param('server_file') ) { + unlink $file; + } + + show_tables( "File Imported Successfully." ); +} + +sub export_record { +# ----------------------------------------------------------------------------- +# Exort records from the table specified and produce a +# delimited text file. +# It is disabled in demo mode. +# + my $export_all_cols = $IN->param('export_all_cols') || ''; + my $delimiter = defined( $IN->param('delimiter') ) ? $IN->param('delimiter') : ''; + my $rec_del = defined( $IN->param('rec_del') ) ? $IN->param('rec_del') : ''; + my $table = $IN->param('table') || ''; + my $file = $IN->param('file') || ''; + my $escape_char = defined( $IN->param('escape_char') ) ? $IN->param('escape_char') : ''; + my $to_screen = $IN->param('export_to_screen') || ''; + if ($to_screen) { $file = get_temp_file_name(); } + + my ( $query, $sth, $file_q, $delimiter_q, $rec_del_q, $escape_char_q, $cols ); + + my @select_fields = $IN->param('ImportRight'); + + + if ( !$to_screen && !$file ) { + sqlerr("Please provide a file name for export."); + return; + } + + if ( !$DBH ) { connect_db() or return; } + +# quote the parameters. + $file_q = $DBH->quote($file); + $delimiter_q = $DBH->quote($delimiter); + $rec_del_q = "'" . $rec_del . "'"; + $escape_char_q = $DBH->quote($escape_char); + + if ($export_all_cols) { # select all fields + $cols = '*'; + } + else { # export selected fields only. + $cols = join ( ",", @select_fields ); + } + + if ( $IN->param('from_save_result') ) { + + my $fields = $IN->param('fields'); + my $action = $IN->param('browse_action'); + + if ( $action eq 'browse' ) { + $query = qq~SELECT * + INTO OUTFILE $file_q + FIELDS + TERMINATED BY $delimiter_q + ESCAPED BY $escape_char_q + LINES TERMINATED BY $rec_del_q + FROM $table~; + } + else { + + my $where_clause = ''; + my $where = $IN->param('where'); + my $example = $IN->param('example'); + + if ($where) { $where_clause = "WHERE $where"; } + +# Query by example. + if ($example) { + if ($where_clause) { $where_clause .= " AND $example"; } + else { $where_clause = "WHERE $example"; } + } + + $query = qq~SELECT $fields + INTO OUTFILE $file_q + FIELDS + TERMINATED BY $delimiter_q + ESCAPED BY $escape_char_q + LINES TERMINATED BY $rec_del_q + FROM $table + $where_clause~; + } + } + else { + $query = qq~SELECT $cols + INTO OUTFILE $file_q + FIELDS + TERMINATED BY $delimiter_q + ESCAPED BY $escape_char_q + LINES TERMINATED BY $rec_del_q + FROM $table~; + } + $sth = exec_query($query) or return; + $sth->finish; + + if ($to_screen) { + print $IN->header( 'text/plain' ); + print "# Exported data from table $table\n"; + print "# A temporary file ($file) was create in the temp directory.\n"; + print "# Please remove the file manually as necessary.\n\n"; + print "# =========== Export Starts ===========\n"; + open( TEMP, $file ) or cgierr("error open file"); + while ( my $line = ) { + print $line; + } + close TEMP; + print "\n# =========== Export Ends ==========="; + + unlink($file); + return 1; + } + elsif ( $IN->param('from_save_result') ) { + table_browse(); + } + else { + return show_tables( "File Exported Successfully." ); + } +} + +sub table_field_prep { +# ----------------------------------------------------------------------------- +# Create options for import and export HTML pages. The +# options are the fields of the table selected. +# + my $table = $IN->param('table') || ''; + my $options = ''; + + if ( !$DBH ) { connect_db() or return; } + my $query = "SELECT * FROM $table LIMIT 1"; + my $sth = exec_query($query) or return; + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} ; $i++ ) { + $options .= + qq~\n~; + } + $sth->finish; + return ( $options, $sth->{NUM_OF_FIELDS} ); +} + +#=================================================# +# Mysqldump # +#=================================================# + +sub mysqldump { +# ----------------------------------------------------------------------------- +# Create dump file. The result is either printed to the +# screen or saved to a file. +# + my $file = $IN->param('dump_file') || ''; + + my $dump_whole_db = $IN->param('dump_whole_db') || ''; + my $op_create_st = $IN->param('op_create_st') || ''; + my $op_dump_db = $IN->param('op_dump_db') || ''; + my $add_drop_table = $IN->param('add_drop_table') || ''; + + my $complete_insert = $IN->param('complete_insert') || ''; + my $delayed_insert = $IN->param('delayed_insert') || ''; + my $extended_insert = $IN->param('extended_insert') || ''; + + my $db_host = $IN->cookie( $CFG{'db_host_cookie_name'} ) || 'localhost'; + if ( $CFG{'direct_connect'} ) { + $db_host = $CFG{'direct_host'} || $db_host; + } + + my ( @table_list, $sth, $query, $table, $table_selected, %ins_options, + @ary ); + + %ins_options = (); + if ($complete_insert) { $ins_options{'complete_insert'} = 1; } + if ($delayed_insert) { $ins_options{'delayed_insert'} = 1; } + if ($extended_insert) { $ins_options{'extended_insert'} = 1; } + + + if ( !$DBH ) { connect_db() or return; } + + $query = "SHOW TABLES"; + $sth = exec_query($query) or return; + + if ($dump_whole_db) { # store all tables in @table_list + while ( ($table) = $sth->fetchrow_array() ) { + push ( @table_list, $table ); + } + } + else { # store selected tables in @table_list. + while ( ($table) = $sth->fetchrow_array() ) { + if ( $IN->param("*dump_table*_$table") ) { + push ( @table_list, $IN->param("*dump_table*_$table") ); + } + } + } + $sth->finish; + + if ( $IN->param("dump_to_screen") ) { + + print $IN->header( 'text/plain' ); + + print qq|# MySQL dump +# Generated by MySQLMan $VERSION (http://gossamer-threads.com/scripts/) +# Host: $db_host Database: | . get_db( $IN->param('data_source') ) . qq| +#-------------------------------------------------------- + +|; + foreach $table_selected (@table_list) { + +# Write CREATE TABLE statement. + if ($op_create_st) { + print "#\n# Table structure for table '$table_selected'\n#\n"; + if ($add_drop_table) { + print "DROP TABLE IF EXISTS $table_selected;\n"; + } + print construct_create_table_statement($table_selected); + } + +# Write INSERT statements. + if ($op_dump_db) { + print "#\n# Dumping data for table '$table_selected'\n#\n\n"; + if ( $CFG{'dump_in_pages'} ) { + $query = "SELECT COUNT(*) FROM $table_selected"; + $sth = exec_query($query) or return; + my ($rows) = $sth->fetchrow_array; + my $pages = $rows / $CFG{'dump_page_length'}; + $pages = int($pages) + 1; + for ( my $j = 1 ; $j <= $pages ; $j++ ) { + print data_dump( $table_selected, $j, %ins_options ); + } + $sth->finish; + } + else { + print data_dump( $table_selected, '', %ins_options ); + } + print "\n"; + } + } + print "# ----------- Dump ends -----------"; + + } + else { + if ( !$file ) { + sqlerr('Please provide a file name for mysqldump.'); + return; + } + +# Check if dump file specified already existed. + if ( not dump_file_check($file) ) { return } + +# create and dump to file. + open( DUMP_FILE, ">>$file" ) + or cgierr("Unable to create dump file '$file': $!"); + + print DUMP_FILE qq|# MySQL dump +# Generated by MySQLMan $VERSION (http://gossamer-threads.com/scripts/) +# Host: $db_host Database: | . get_db( $IN->param('data_source') ) . qq| +#-------------------------------------------------------- + +|; + foreach $table_selected (@table_list) { + +# Write CREATE TABLE statement. + if ($op_create_st) { + print DUMP_FILE + "#\n# Table structure for table '$table_selected'\n#\n"; + if ($add_drop_table) { + print DUMP_FILE "DROP TABLE IF EXISTS $table_selected;\n"; + } + print DUMP_FILE construct_create_table_statement( + $table_selected); + } + +# Write INSERT statements. + if ($op_dump_db) { + print DUMP_FILE + "#\n# Dumping data for table '$table_selected'\n#\n\n"; + if ( $CFG{'dump_in_pages'} ) { + $query = "SELECT COUNT(*) FROM $table_selected"; + $sth = exec_query($query) or return; + my ($rows) = $sth->fetchrow_array; + my $pages = $rows / $CFG{'dump_page_length'}; + $pages = int($pages) + 1; + for ( my $j = 1 ; $j <= $pages ; $j++ ) { + print DUMP_FILE data_dump( $table_selected, $j, + %ins_options ); + } + $sth->finish; + } + else { + print DUMP_FILE data_dump( $table_selected, '', + %ins_options ); + } + print DUMP_FILE "\n"; + } + } + print DUMP_FILE "# ----------- Dump file ends -----------"; + close(DUMP_FILE); + + show_tables( "Dump file created" ); + } +} + +sub construct_create_table_statement { +# ----------------------------------------------------------------------------- +# Given a table name, construct a a CREATE TABLE statement +# that creates the exact table. + + my ($table) = @_; + my ( + $sth, $query, $create_query, + $col_spec, $type, $key_name, + $non_unique, $not_null, @key_col, + @build_key_statement, $key_spec + ); + my ( $field, $type_name, $length_set, $attributes, $null, $key, $default, + $extra ); + + my @col_spec = (); + + $query = qq~DESCRIBE $table~; + $sth = exec_query($query) or return; + +# Construct column specifications. + while ( my @ary = $sth->fetchrow_array ) { + ( + $field, $type_name, $length_set, $attributes, $null, $key, $default, + $extra + ) + = parse_col_spec(@ary) + or return; + if ($null) { $not_null = '' } + else { $not_null = 'NOT NULL' } + if ($length_set) { $length_set = "($length_set)" } + if ( ( defined $default ) or ($not_null) ) { + if ( not defined $default ) { $default = ''; } + $default = "DEFAULT " . $DBH->quote($default); + } + $col_spec = +" $field $type_name$length_set $attributes $default $not_null $extra"; + push ( @col_spec, $col_spec ); + } + $sth->finish; + +# find out if there are keys in the table. + $query = qq~SHOW KEYS FROM $table~; + $sth = exec_query($query) or return; + + $key_name = ''; + @build_key_statement = (); + while ( my @ary = $sth->fetchrow_array ) { + my $cur_non_unique = $ary[1]; + my $cur_key_name = $ary[2]; + my $col = $ary[4]; + if ( $key_name eq $cur_key_name ) { push ( @key_col, $col ); } + else { + if ($key_name) { + if ( $key_name eq 'PRIMARY' ) { + $key_spec = + ' PRIMARY KEY (' . join ( ",", @key_col ) . ')'; + } + elsif ($non_unique) { + $key_spec = + " KEY $key_name (" . join ( ",", @key_col ) . ')'; + } + else { + $key_spec = + " UNIQUE $key_name (" . join ( ",", @key_col ) . ')'; + } + push ( @build_key_statement, $key_spec ); + } + @key_col = (); + push ( @key_col, $col ); + $key_name = $cur_key_name; + $non_unique = $cur_non_unique; + } + } + + $sth->finish; + + if ($key_name) { + if ( $key_name eq 'PRIMARY' ) { + $key_spec = ' PRIMARY KEY (' . join ( ",", @key_col ) . ')'; + } + elsif ($non_unique) { + $key_spec = " KEY $key_name (" . join ( ",", @key_col ) . ')'; + } + else { + $key_spec = " UNIQUE $key_name (" . join ( ",", @key_col ) . ')'; + } + push ( @build_key_statement, $key_spec ); + } + + if (@build_key_statement) { + $create_query = + "CREATE TABLE $table (\n" + . join ( ",\n", @col_spec ) . ",\n" + . join ( ",\n", @build_key_statement ) + . "\n);\n\n"; + } + else { + $create_query = + "CREATE TABLE $table (\n" . join ( ",\n", @col_spec ) . "\n);\n\n"; + } + + return $create_query; +} + +sub data_dump { +# ----------------------------------------------------------------------------- +# Construct INSERT TABLE statements for a given table. + + my ( $table, $page, %options ) = @_; + my ( $sth, $query, $count, @ary, $field, @records, @fields, + $insert_statement, $not_first_rec ); + + my $complete_insert = $options{'complete_insert'} || ''; + my $delayed_insert = $options{'delayed_insert'} || ''; + my $extended_insert = $options{'extended_insert'} || ''; + + $query = qq~SELECT COUNT(*) FROM $table~; + $sth = exec_query($query) or return; + ($count) = $sth->fetchrow_array; + $sth->finish; + + if ( !$page ) { $query = "SELECT * FROM $table"; } + else { + my $start_row = $CFG{'dump_page_length'} * ( $page - 1 ); + $query = + "SELECT * FROM $table LIMIT $start_row, $CFG{dump_page_length}"; + } + $sth = exec_query($query) or return; + +# if complete-insert option is selected, construct the fields in the table. + my $complete_op_fields = ''; + my @field_list = (); + if ($complete_insert) { + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} ; $i++ ) { + push ( @field_list, $sth->{NAME}->[$i] ); + } + $complete_op_fields = '(' . join ( ",", @field_list ) . ')'; + } + +# if delayed-insert option is selected, added DELAYED keyword in INSERT statements. + my $delayed_keyword = ''; + if ($delayed_insert) { $delayed_keyword = 'DELAYED' } + + $not_first_rec = 0; + while ( @ary = $sth->fetchrow_array ) { + @fields = (); + foreach $field (@ary) { + if ( defined($field) ) { push ( @fields, $DBH->quote($field) ); } + else { push ( @fields, 'NULL' ) } + } + + if ($extended_insert) { + if ($not_first_rec) { + $insert_statement .= ",(" . join ( ",", @fields ) . ")"; + } + else { + $insert_statement = +"INSERT $delayed_keyword INTO $table $complete_op_fields VALUES(" + . join ( ",", @fields ) . ")"; + $not_first_rec = 1; + } + } + else { + $insert_statement = + "INSERT $delayed_keyword INTO $table $complete_op_fields VALUES(" + . join ( ",", @fields ) . ");\n"; + } + + if ( !$extended_insert ) { push ( @records, $insert_statement ); } + } + if ($extended_insert) { + if ($insert_statement) { $insert_statement .= ";\n"; } + push ( @records, $insert_statement ); + } + + $sth->finish; + return @records; +} + +sub dump_file_check { +# ----------------------------------------------------------------------------- +# Check to see if the dump file specified already existed. +# returns 1 if there isn't such file; undef if there is. + + my $file = shift; + my ($dir) = $file =~ m,(.*)[/\\][^/\\]+,; + if ( -e $file ) { + sqlerr("File '$file' already exists. Please use another file name."); + return; + } + elsif ( $dir and !-w $dir ) { + sqlerr( +"Can not create file in '$dir' directory. Please use another file name." + ); + return; + } + elsif ( !$dir and !-w '.' ) { + sqlerr( +"Can not create file in '.' directory. Please use another file name." + ); + return; + } + else { + return 1; + } +} + +sub get_checkbox_tables_in_database { +# ----------------------------------------------------------------------------- +# get the list of tables of the database that the user +# is currently in and create a checkbox for each name for +# SQL dump +# + my ( $sth, $query, $table, $table_checkboxes ); + + if ( !$DBH ) { connect_db() or return; } + + $query = "SHOW TABLES"; + $sth = exec_query($query) or return; + + $table_checkboxes = []; + while ( ($table) = $sth->fetchrow_array ) { + push @$table_checkboxes, { name => $table }; + } + $sth->finish; + return $table_checkboxes; +} + +#=================================================# +# UTILITIES # +#=================================================# + +sub build_saved_query_table { +# ----------------------------------------------------------------------------- +# build a table for queries saved. +# + my $query_table = []; + + if ( $IN->cookie('query_1') ) { + for ( my $j = 10 ; $j >= 1 ; $j-- ) { + + my $partial_query; + my @temp = split / /, $IN->cookie("query_$j"); + + if ( $#temp > 10 ) { + $partial_query = +"$temp[0] $temp[1] $temp[2] ... $temp[$#temp-2] $temp[$#temp-2] $temp[$#temp]"; + } + else { + $partial_query = $IN->cookie("query_$j"); + } + + if ( $IN->cookie("query_$j") ) { + push @$query_table, { + num => $j, + partial_query => $IN->html_escape($partial_query), + show_link => qq~$CFG{'script_url'}?$CFG{do}=show_query&query_displayed=$j~ + }; + } + } + } + + return $query_table; +} + +sub create_temp_file { +# ----------------------------------------------------------------------------- +# creates a temp file and return the path to the file. +# + my $temp_file = get_temp_file_name(); + my $fh = $IN->param('upload_local_file') || ''; + + if ( !$fh ) { sqlerr('Query file not specified.'); return; } + + if ( !open( OUTFILE, ">$temp_file" ) ) { + cgierr( + "There was an error opening temp file '$temp_file' for writing.\n"); + } + + open( OUTFILE, ">>$temp_file" ); + my ($buffer); + while ( read( $fh, $buffer, 1024 ) ) { + print OUTFILE $buffer; + } + + close($fh); + close(OUTFILE); + chmod( 0666, "$temp_file" ); + + return $temp_file; +} + +sub get_temp_file_name { +# ----------------------------------------------------------------------------- +# This function creates a random temp file name, looks +# up the temp directory and returns the path to the +# temp file. + + my $temp_file_path = ''; + my $directory = '.'; + my @temp_dirs = + ( "/usr/tmp", "/var/tmp", "C:/temp", "/tmp", "/temp", "/WWW_ROOT" ); + foreach (@temp_dirs) { + if ( -d $_ && -w _ ) { $directory = $_; last; } + } + my $rand_name = "GTMM" . time . $$ . int( rand(1000) ); + while ( -e $directory . '/' . $rand_name ) { + $rand_name = "GTMM" . time . $$ . int( rand(1000) ); + } + $temp_file_path = "$directory/$rand_name"; + return $temp_file_path; +} + +sub parse_col_spec { +# ----------------------------------------------------------------------------- +# Given a column specification from DESCRIBE TABLE, the function +# finds out +# field name +# typename +# length/set +# attributes +# if nullable +# if set as key +# default +# extra property. + + my @ary = @_; + + my $field = $ary[0]; + my $type = $ary[1]; + my $null = $ary[2]; + my $key = $ary[3]; + my $default = $ary[4]; + my $extra = $ary[5]; + + my ( + $chop_att, $attributes, $dump, $value_q, + $value_unquote, $type_name, $length_set, @type_field, + @length_set, @new_length_set, $new_length_set + ); + +# Get column type. + ( $type_name, $dump ) = split /([(])/, $type, 2; + +# Get length/set + $length_set = ''; + + my @t = split / /, $type; + if ( ( $t[0] ne $t[$#t] ) + && ( ( $type_name ne 'set' ) && ( $type_name ne 'enum' ) ) ) + { + for ( my $i = 0 ; $i < $#t ; $i++ ) { $chop_att .= $t[$i] } + } + else { $chop_att = $type } + my @tmp = split /([()])/, $chop_att; + my $flag = 0; + for ( my $i = 0 ; $i < $#tmp ; $i++ ) { + if ($flag) { $length_set .= $tmp[$i]; } + if ( $tmp[$i] eq '(' ) { $flag = 1; } + } + +# Get Attribute. + @type_field = split / /, $type; + if ( ( $type_field[0] ne $type_field[$#type_field] ) + && ( ( $type_name ne 'set' ) && ( $type_name ne 'enum' ) ) ) + { + $attributes = $type_field[$#type_field]; + } + else { $attributes = ''; } + + if ( $type_name eq 'set' || $type_name eq 'enum' ) { + +# Get the elements in length/set. + @length_set = parse_length_set($length_set); + + foreach (@length_set) { + if ( $_ ne "''" ) { + ($value_unquote) = $_ =~ m{^\'(([^\']|\'\')+)\'}; + $value_unquote =~ s/''/\\'/g; + $value_unquote =~ s/,/\\,/g; + $value_q = "'" . $value_unquote . "'"; + } + push ( @new_length_set, $value_q ); + } + $new_length_set = join ",", @new_length_set; + } + else { $new_length_set = $length_set } + + return ( $field, $type_name, $new_length_set, $attributes, $null, $key, + $default, $extra ); +} + +sub set_col_not_null { +# ----------------------------------------------------------------------------- +# Takes in a table name and the column name. Then +# function will make the column specified not nullable. +# It will first read in the current spec of the column +# and then reconstruct the spec to set the column not null. +# + my $table = $IN->param('table') || ''; + my $col = $IN->param('col') || ''; + + my ( $sth, $query, @attr, $new_spec, $col_q ); + + $col_q = $DBH->quote($col); + + if ( !$DBH ) { connect_db() or return; } + $query = "SHOW COLUMNS FROM $table LIKE $col_q"; + $sth = exec_query($query) or return; + @attr = $sth->fetchrow_array(); + +# reconstruct spec and set column not null. + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} ; $i++ ) { + if ( $i == 2 ) { $new_spec .= ' NOT NULL '; } + elsif ( ( $i == 4 ) && ( defined( $attr[$i] ) ) ) { + $new_spec .= " DEFAULT " . $DBH->quote( $attr[$i] ); + } + elsif ( ( $i == 3 ) || ( $i == 6 ) ) { } + else { $new_spec .= " $attr[$i] "; } + } + $sth->finish; + + $query = "ALTER TABLE $table CHANGE $col $new_spec"; + $sth = exec_query($query) or return; + $sth->finish; +} + +sub get_pri_key { +# ----------------------------------------------------------------------------- +# Gets the primary key of the table specified. + + my $table = shift; + my ( $sth, $query, @ary, @pri_key ); + + @pri_key = (); + + $query = "DESCRIBE $table"; + $sth = exec_query($query) or return; + while ( @ary = $sth->fetchrow_array ) { + if ( $ary[3] eq 'PRI' ) { push ( @pri_key, $ary[0] ); } + } + $sth->finish; + + return @pri_key; +} + +sub get_table_list { +# ----------------------------------------------------------------------------- +# Gets the list of tables which the query input is querying +# from. Since the function is only used in "sub table_browse"; +# + + my $query = shift; + my ( + @query, $token, $flag, @table_list, + $cur_token, $pre_token, $stop, $cmd, + $explain_select, $got_list + ); + +#strip beginning and endding space. + $query =~ s/^\s+//; + $query =~ s/\s+$//; + $query =~ s/(\r|\n)+/ /g; + + @query = split /([ ,])/, $query; + $cmd = lc( $query[0] ); + +# find table list from: +# 1. describe / desc +# 2. explain table + if ( ( $cmd eq 'describe' ) || ( $cmd eq 'desc' ) || ( $cmd eq 'explain' ) ) + { + + @table_list = (); + $flag = 0; + + for ( my $i = 1 ; $i <= $#query ; $i++ ) { + if ( defined( $query[$i] ) ) { + if ( ( $query[$i] ne '' ) + && ( $query[$i] ne ' ' ) + && ( $query[$i] ne ',' ) ) + { + +# get the first name after the command. + if ( $flag == 0 ) { + push ( @table_list, $query[$i] ); + my $tmp = lc( $query[$i] ); + if ( $tmp eq 'select' ) { $explain_select = 1 } + $flag = 1; + } + } + } + } + $got_list = 1; + } + +# find table list from queries like: +# 1. select queries +# 2. show queries +# 3. explain select .... + if ( !$got_list || $explain_select ) { + + @table_list = (); + $flag = 0; + $stop = 0; + $pre_token = ''; + + foreach (@query) { + if ( ( $_ ne '' ) && ( $_ ne ' ' ) ) { + $token = lc($_); + if ( $flag == 1 ) { + +# determine the type of the current token. + if ( $token ne ',' ) { $cur_token = 'word' } + else { $cur_token = 'comma' } + +# stop then the "from" clause ends + if ( ( $cur_token eq 'word' ) + && ( $cur_token eq $pre_token ) ) + { + $stop = 1; + } + + if ( !$stop && $token ne ',' ) { push ( @table_list, $_ ) } + $pre_token = $cur_token; + } + if ( $token eq 'from' ) { $flag = 1; } + } + } + } + return @table_list; +} + +sub form_fields { +# ----------------------------------------------------------------------------- +# Create a form input table for insert and edit. $update +# is a flag indicating whether or not it is from edit. @value +# consists the list of original values (in order) in the +# record being updated. Note that in order to set a field +# to be null, the input value has to be null. In other words, +# if there is value in input field and null checkbox is checked, +# the null option will be overwritten and the value in the input +# field will be taken. +# +# Option: you can set it in the config file such that any colume +# with type TIMESTAMP will not be shown in the form. + + my ( $update, @value ) = @_; + + my $table = $IN->param('table') || ''; + my ( + $query, $sth, $form_table, @ary, + @type, @domain, @domain_new, %domain_h, + $value_unquote, $flag, $double_comma, $length_set + ); + + my @timestamp_hidden = (); + + if ( !$DBH ) { connect_db() or return; } + + $query = "DESCRIBE $table"; + $sth = exec_query($query) or return; + + $form_table = []; + + my $k = 0 + ; # Value counter. Used to identify which element in @value is considered. + + while ( @ary = $sth->fetchrow_array ) { + my $tabindex_count = $k + 1; + +# $ary[1] is in the form "type_name(length_set) attribute" +# + @type = split /([(])/, $ary[1]; + $length_set = ''; + for ( my $j = 2 ; $j <= $#type ; $j++ ) { $length_set .= $type[$j]; } + chop $length_set; + + my $ins = { + field => $ary[0], + type => $type[0], + }; + if ( $CFG{'insert_null'} ) { + if ( $ary[2] eq 'YES' ) { + $ins->{nullable} = 1; + if ( !defined( $value[$k] ) && $update ) { + $ins->{null} = 1; + } + else { + $ins->{null} = 0; + } + } + else { + $ins->{nullable} = 0; + } + } + +# Handle type 'Enum' + if ( $type[0] eq 'enum' ) { + $ins->{function_select} = function_select($ary[0]); + my $select = ''; + if ( defined( $value[$k] ) && $update ) { + $select .= qq~~; + } + +# Create an empty choice. This choice available even if it is not specified in +# enum. We need it in case the value needs to be null. + $select .= qq~\n~; + +# All other choices in specified in the enumeration. + @type = parse_length_set($length_set); + + for ( my $i = 0 ; $i <= $#type ; $i++ ) { + if ( defined( $type[$i] ) + && $type[$i] ne "''" + && $type[$i] ne '' ) + { + ($value_unquote) = $type[$i] =~ m{^\'(([^\']|\'\')+)\'}; + +# Since MySQL stores single quotes in 2 single quotes in column specs, +# we translate them back to 1. + $value_unquote =~ s/''/'/g; + $value_unquote =~ s/\\\\/\\/g; #/ + $select .= qq~\n~; + } + } + + $ins->{enum_select_options} = \$select; + push @$form_table, $ins; + } + +# Handle type 'Set' + elsif ( $type[0] eq 'set' ) { + + my $j = 0; + + $ins->function_select( $ary[0]); + +# For update, check if '' is in the set. + @domain = split /(,)/, $value[$k]; + foreach (@domain) { + if ( $_ ne ',' ) { + if ( $_ ne '' ) { push ( @domain_new, $_ ) } + else { push ( @domain_new, "''" ) } + } + } + if ( $domain[$#domain] eq ',' ) { push ( @domain_new, "''" ); } + %domain_h = map { $_ => 1 } @domain_new; + + @type = parse_length_set($length_set); + my @set_options; + + for ( my $i = 0 ; $i <= $#type ; $i++ ) { + + if ( defined( $type[$i] ) && $type[$i] ne '' ) { + + if ( $type[$i] ne "''" ) { + ($value_unquote) = $type[$i] =~ m{^\'(([^\']|\'\')+)\'}; + } + else { $value_unquote = $type[$i]; } + + if ( $value_unquote ne "''" ) { + $value_unquote =~ s/''/'/g; + } + $value_unquote =~ s/\\\\/\\/g; #// + +# Create checkboxes for each element in the set. Checkboxes are checked if +# value is selected in the original set. + my $opt = { + value => $IN->html_escape($value_unquote), + num => $j, + checked => 0 + }; + if ( $domain_h{$value_unquote} ) { + $opt->{checked} = 1; + } + push @set_options, $opt; + $j++; + } + } + $ins->{set_options} = \@set_options; + push @$form_table, $ins; + } + +# Handle all other types + else { + my $type_lookup = lc( $ary[1] ); + my $hidden_field = ''; + +# hide columns with type TIMESTAMP if necessary. + if ( ( $type_lookup =~ m/timestamp/ ) + && !$CFG{'show_timestamp_field'} ) + { + if ( !$update ) { + $hidden_field = qq~~; + push ( @timestamp_hidden, $hidden_field ); + } + else { + $hidden_field = + qq~~; + push ( @timestamp_hidden, $hidden_field ); + } + } + else { + $ins->{value} = \$IN->html_escape( $value[$k] ); + $ins->{function_select} = function_select( $ary[0] ); + push @$form_table, $ins; + } + } + $k++; + } + $sth->finish; + + my $form_hidden = ''; + if (@timestamp_hidden) { + $form_hidden = \join ( "", @timestamp_hidden ); + } + + return($form_table, $form_hidden); +} + +sub parse_length_set { +# ----------------------------------------------------------------------------- +# A simple parser that gets each element in the length set field. +# Basically, it counts the number for sigle quotes. Each element +# must have even number of quotes. If a comma encountered, then +# the check the number for quotes seen so far. If the number is odd, +# then concate the comma to temp string, otherwise, push the current +# tmep string to array. + + my ($length_set) = @_; + + my @type = split /([,'])/, + $length_set; # list of quoted elements in length_set + my @new_type = (); + my $remainder = 0; + my $cur_choice = ''; + my $q_count = 0; + my $begin = 0; + my $k = 0; + + foreach my $element (@type) { + if ( $k == $#type ) { + $cur_choice .= $element; + push ( @new_type, $cur_choice ); + } + elsif ( $element ne '' ) { + if ( $element eq ',' ) { + $remainder = $q_count % 2; + if ($remainder) { + if ($begin) { + push ( @new_type, $cur_choice ); + $begin = 0; + $q_count = 0; + $cur_choice = ''; + } + else { + $begin = 1; + $cur_choice .= $element; + $q_count = 0; + } + } + else { + if ($begin) { + $cur_choice .= $element; + } + else { + push ( @new_type, $cur_choice ); + $q_count = 0; + $cur_choice = ''; + } + } + } + elsif ( $element eq "'" ) { + $q_count++; + $cur_choice .= $element; + } + else { + $cur_choice .= $element; + } + } + $k++; + } + return @new_type; +} + +sub compose_new_condition { +# ----------------------------------------------------------------------------- +# Reconstructs the input from "sub form_fields" to an array +# of "field = value" pairs. +# +# The functions is modified after v1.03 +# The way that the script inserts a record is changed to +# +# INSERT INTO tablename (column1,column2,...columnn) +# VALUES (value1,value2, .. valuen) +# +# as the SET col=val isn't supported by all versions of mysql. +# Therefore, if is_insert flag in on, the function returns +# a array in the following format: +# +# (field_name_1, value_for_field_name_1, field_name_2, value_for_field_name_2, ...) +# +# Please note that the value in $value is quoted. +# + + my ( $is_insert ) = @_; + my $table = $IN->param('table') || ''; + my ( + $query, $prep, $sth, @ary, + $value, @insert_fields, @type, @set, + $new_record, $value_unquote + ); + + $query = "DESCRIBE $table"; + $prep = exec_query($query) or return; + + while ( @ary = $prep->fetchrow_array ) { + + @type = split /[(),]/, $ary[1]; + +# Handle columns of type 'SET' + if ( $type[0] eq 'set' ) { + my $j = 0; # checkbox counter + my $k = 0; # counter for how many checkboxes are checked. + +# check each checkbox box to see if they are check. + for ( my $i = 1 ; $i < ( $#type + 1 ) ; $i++ ) { + ($value_unquote) = $type[$i] =~ m{^\'(([^\']|\'\')+)\'}; + if ( defined( $type[$i] ) ) { + if ( defined( $IN->param("*insert*_$ary[0]_set_$j") ) ) { + if ( $IN->param("*insert*_$ary[0]_set_$j") ne "''" ) { + push ( @set, + $IN->param("*insert*_$ary[0]_set_$j") ); + } + else { push ( @set, '' ); } + $k++; + } + $j++; + } + } + + $value = $DBH->quote( join ( ",", @set ) ); + +# If none of the checkboxes is checked, check for null option. + if ( !$k ) { + if ( $IN->param("*insert*_$ary[0]_null") ) { $value = 'NULL'; } + else { $value = '""'; } + } + + } + +# Handle all other types. + else { + +# if nothing in input field. + if ( !$IN->param("*insert*_$ary[0]") + && ( $IN->param("*insert*_$ary[0]") ne '0' ) ) + { + +# check for null + if ( $IN->param("*insert*_$ary[0]_null") ) { $value = 'NULL'; } + +# check for function. + else { + if ( $IN->param("*insert*_$ary[0]_function") ) { + $value = $IN->param("*insert*_$ary[0]_function") . '()'; + } + else { $value = '""'; } + } + } + +# check if any function is needed to apply on the input. + elsif ( $IN->param("*insert*_$ary[0]_function") ) { + $value = + $IN->param("*insert*_$ary[0]_function") . '(' + . $DBH->quote( $IN->param("*insert*_$ary[0]") ) . ')'; + } + +# otherwise make the field equal to the value entered. + else { $value = $DBH->quote( $IN->param("*insert*_$ary[0]") ); } + } + if ($is_insert) { + push ( @insert_fields, $ary[0] ); + push ( @insert_fields, $value ); + } + else { + push ( @insert_fields, "$ary[0] = $value" ); + } + } + $prep->finish; + + return (@insert_fields); +} + +sub function_select { +# ----------------------------------------------------------------------------- +# Creates enumeration of functions available in select input. + + my ( $field ) = @_; + + return \html_display( + 'functions.txt', + { + field => $field, + do_param => $CFG{do} + }, + { print => 0 } + ); +} + +sub get_key_table { +# ----------------------------------------------------------------------------- +# Creates a key/index table. A "drop" link is created +# together with each each read in. +# + my $data_source = $IN->param('data_source') || ''; + my $table = $IN->param('table') || ''; + my ( + $sth, $query, @ary, $unique, $non_unique, + $key_name, $column_name, $keys + ); + + $query = "SHOW INDEX from $table"; + $sth = exec_query($query) or return; + $keys = []; + while ( @ary = $sth->fetchrow_array ) { + my $non_unique = $ary[1]; + my $key_name = $ary[2]; + my $column_name = $ary[4]; + if ($non_unique) { $unique = 'NO'; } + else { $unique = 'YES'; } + push @$keys, { + name => $key_name, + unique => $unique, + column_name => $column_name, + drop_link => qq~$CFG{'script_url'}?$CFG{do}=alter_table&data_source=$data_source&table=$table&action=drop_key&key_name=$key_name~ + }; + } + $sth->finish; + + return $keys; +} + +sub get_db { +# ----------------------------------------------------------------------------- +# Gets the database name from the data source which is +# in the format "DBI:mysql:database_name:host" + + my $db = shift; + + my @dsn = split /([:])/, $db; + $db = $dsn[4]; + if ( $CFG{'direct_connect'} ) { $db = $CFG{'direct_db'}; } + + return $db; +} + +sub get_cols { +# ----------------------------------------------------------------------------- +# Takes in a table name and return the columns in an ] +# array. + + my ( $table ) = @_; + my ( $query, $sth, @cols ); + if ( !$DBH ) { connect_db() or return; } + $query = "SELECT * FROM $table LIMIT 1"; + $sth = exec_query($query) or return; + for ( my $i = 0 ; $i < $sth->{NUM_OF_FIELDS} ; $i++ ) { + push ( @cols, $sth->{NAME}->[$i] ); + } + $sth->finish; + return @cols; +} + +sub valid_name_check { +# ----------------------------------------------------------------------------- +# Checks to see if the input database/table name is a +# valid one. The function checks the following: +# 1. if a name is entered at all; +# 2. if there are spaces in the name; +# 3. if the name is consisted of valid characters; and +# 4. if the name is consisted of only numbers. + + my $name = shift; + + $name =~ s/^\s+//; + $name =~ s/\s+$//; + + my @name = split / /, $name; + + if ( !$name ) { sqlerr("Please provide a valid name."); } + elsif ( $#name > 0 ) { sqlerr("Spaces are not allowed in name."); } + elsif ( $name =~ m/[^\w_\$]/ ) { + sqlerr( + "Invalid name. A name may consist of characters, numbers, and also '_' and '\$'." + ); + } + elsif ( !( $name =~ m/\D/ ) ) { + sqlerr("Invalid name. A name may not consist only of numbers."); + } + else { return 1; } +} + +sub alias_name_check { +# ----------------------------------------------------------------------------- +# Checks to see if the input table name is of the format +# 1. database.table.column OR +# 2. table.column + + my ( $table ) = @_; + my @alias_table = split /[.]/, $table; + + if ( $#alias_table > 0 ) { + html_demo_prompt( 'Action not allowed in demo mode' ); + } + else { return 1; } +} + +sub concate_col_spec { +# ----------------------------------------------------------------------------- +# Reconstruct the input variables into a string in the form +# "field_name(type(length_set) attribute DEFAULT default_value extra)" + + my ( $i ) = @_; + my $col_spec; + + $col_spec = ''; + $col_spec .= $IN->param("field_$i") . ' '; + $col_spec .= $IN->param("type_$i"); + if ( $IN->param("length_set_$i") ) { + $col_spec .= '(' . $IN->param("length_set_$i") . ')'; + } + $col_spec .= ' ' . $IN->param("attributes_$i") . ' '; + $col_spec .= $IN->param("null_$i") . ' '; + my $default = $IN->param("default_$i"); + if ( length $default ) { + $col_spec .= 'DEFAULT ' . $DBH->quote($default) . ' '; + } + $col_spec .= $IN->param("extra_$i"); + + return $col_spec; +} + +sub link_page { +# ----------------------------------------------------------------------------- +# Provides hyperlinks to next, previous, or top pages when needed + + my ( $rows, $table, $fields, $example, $index, $total_rec_num ) = @_; + my ( + $data_source, $cur_page, $page, $output, $sort_index, + $action, $where, $query, $cur_rec_num, $more_page + ); + + $data_source = $IN->param("data_source") || ''; + $cur_page = $IN->param("page") || 1; + $sort_index = $index; + $action = $IN->param("browse_action") || $IN->param("action") || ''; + $where = $IN->escape( $IN->param("where") ) || ''; + $query = $IN->escape( $IN->param("query") ) || ''; + + $example = $IN->escape($example); + + $cur_rec_num = ( $cur_page - 1 ) * $CFG{'page_length'} + $rows; + if ( $cur_rec_num < $total_rec_num ) { $more_page = 1; } + else { $more_page = 0; } + + $output = ''; + +# the very first page. + if ( ( $cur_page == 1 ) + and ( $rows == $CFG{'page_length'} ) + and ($more_page) ) + { + $page = $cur_page + 1; + $output .= qq~< Next page >~; + } + +# the very last page. + elsif ( ( !$more_page ) and ( $cur_page != 1 ) ) { + $page = $cur_page - 1; + $output .= qq~< Previous page > ~; + } + +# any page between the first and the last page. + elsif ( ( $cur_page != 1 ) + and ( $rows == $CFG{'page_length'} ) + and ($more_page) ) + { + $page = $cur_page + 1; + $output .= qq~< Next page > ~; + $page = $cur_page - 1; + $output .= qq~< Previous page > ~; + } + +# else there is only one page to display. As a result, no links are available. + +# link to jump back to the first page. + if ( ( $cur_page != 1 ) ) { + $output .= qq~< Top page >~; + } + return $output; +} + +sub link_page_jump { +# ----------------------------------------------------------------------------- +# Produces a text field to let the user enter a number +# and the user will be brought to the page specified. + + my ( $sth, $table, $where, $action, $query, $data_source, $pages, $output ); + + my ( $fields, $example, $index, $rows ) = @_; + + $data_source = $IN->param("data_source") || ''; + $table = $IN->param("table") || ''; + $where = $IN->param("where") || ''; + $action = $IN->param("browse_action") || $IN->param("action") || ''; + + $pages = $rows / $CFG{'page_length'}; + if ( ( $rows % $CFG{'page_length'} ) != 0 ) { $pages = int($pages) + 1 } + if ( $rows > $CFG{'page_length'} ) { + return html_page_jump( $pages, $fields, $example, $index ); + } + else { return ''; } +} + +sub record_count { +# ----------------------------------------------------------------------------- +# Counts to total number of records/rows in the table +# specified. + + my ( $sth, $rows, $query ); + + my $tablename = shift; + + $query = "SELECT COUNT(*) FROM $tablename"; + $sth = exec_query($query) or return; + $rows = $sth->fetchrow; + $sth->finish; + return $rows; +} + +sub get_col_type { +# ----------------------------------------------------------------------------- +# Gets the type each field/column of the table specified. + + my $table = shift; + my ( $sth, $query, @ary, @type_ary ); + + $query = "DESCRIBE $table"; + $sth = exec_query($query) or return; + while ( @ary = $sth->fetchrow_array() ) { + push ( @type_ary, $ary[1] ); + } + $sth->finish; + return @type_ary; +} + +sub get_pre_query { +# ----------------------------------------------------------------------------- + + my $i = $IN->param('query_select') || ''; + + if ( not $i ) { + return 0; + } + else { + return $IN->cookie("query_$i"); + } +} + +sub do_login { +# ----------------------------------------------------------------------------- +# Assign login info to cookies. +# + assign_auth_cookie(); + +# redirects the user to the database list if init_login flag is on. + if ( $IN->param('init_login') ) { + my $redirect_url = + $CFG{'script_url'} + . "?$CFG{do}=" + . $IN->param( $CFG{do} ) + . '&data_source=' + . $IN->param('data_source') + . '&init_login=' + . $IN->param('init_login'); + print $IN->redirect( + -url => $redirect_url, + -cookie => \@COOKIES + ); + return 1; + } + else { + print $IN->header( -cookie => \@COOKIES ); + } + + return html_back(); +} + +sub assign_auth_cookie { +# ----------------------------------------------------------------------------- +# assign values to cookies used in the scirpt. +# + my $db_host = $IN->param('db_host'); + my $db_user = $IN->param('db_user'); + my $db_pass = $IN->param('db_pass'); + my $expire = $IN->param('db_expire') ? "+5y" : ""; + + push @COOKIES, $IN->cookie( + -name => $CFG{'db_host_cookie_name'}, + -value => $db_host, + -expires => $expire, + -httponly => 1, + ); + + push @COOKIES, $IN->cookie( + -name => $CFG{'db_user_cookie_name'}, + -value => $db_user, + -expires => $expire, + -httponly => 1, + ); + + push @COOKIES, $IN->cookie( + -name => $CFG{'db_pass_cookie_name'}, + -value => $db_pass, + -expires => $expire, + -httponly => 1, + ); +} + +sub assign_cookies { +# ----------------------------------------------------------------------------- +# assign the current url to cookie. This function tells +# the script where to go to after each login. Also, if a +# query is entered in the SQL monitor, the query will be saved +# as a cookie if requested. +# + my $cur_url; + if ( defined $ENV{REQUEST_METHOD} + and ( uc $ENV{REQUEST_METHOD} ne 'POST' ) ) + { + $cur_url = $IN->url; + } + else { + $cur_url = $IN->url( query_string => 0 ); + } + my $url_modified = 0; + my $data_source = $IN->param('data_source') || ''; + my $table = $IN->param('table') || ''; + my $action = $IN->param('action') || ''; + my $new_do = ''; + my $new_action = ''; + my $query = $IN->param('query') || ''; + my $query_esc = $IN->escape($query); + + if ( $IN->param( $CFG{do} ) eq 'database' ) { + if ( $IN->param('comfirmed') || ( $action eq 'create_db' ) ) { + $data_source = ''; + $new_do = ''; + $url_modified = 1; + } + } + elsif ( $IN->param( $CFG{do} ) eq 'insert_record' ) { + $new_do = "$CFG{insert_origin}"; + $url_modified = 1; + } + elsif ( $IN->param( $CFG{do} ) eq 'modify' ) { + if ( $IN->param('comfirmed') ) { + $new_do = 'tables'; + $url_modified = 1; + } + } + elsif ( $IN->param( $CFG{do} ) eq 'create_table' ) { + $new_do = 'tables'; + $url_modified = 1; + } + elsif ( $IN->param( $CFG{do} ) eq 'alter_table' ) { + if ( ( $action ne 'alter_col' ) && ( $action ne 'do_alter_col' ) ) { + $new_do = 'property'; + $url_modified = 1; + } + } + elsif ($IN->param( $CFG{do} ) eq 'sql_monitor' + || $IN->param( $CFG{do} ) eq 'sql_monitor_file' ) + { + $new_do = 'top_level_op'; + $new_action = 'sql_monitor'; + $url_modified = 1; + } + elsif ( $IN->param( $CFG{do} ) eq 'import' ) { + $new_do = 'tables'; + $url_modified = 1; + } + elsif ( $IN->param( $CFG{do} ) eq 'export' ) { + $new_do = 'tables'; + $url_modified = 1; + } + elsif ( $IN->param( $CFG{do} ) eq 'mysqldump' ) { + $new_do = 'tables'; + $url_modified = 1; + } + else { # do nothing + } + + if ($url_modified) { + $cur_url = + $CFG{'script_url'} + . "?$CFG{do}=$new_do&data_source=$data_source&action=$new_action&table=$table"; + } + push @COOKIES, $IN->cookie( + -name => $CFG{'url_cookie_name'}, + -value => $cur_url, + -path => "/" + ); + +# store URL to cookie. Save query to cookie if needed. + if ( $IN->param('from_monitor') ) { + if ( $IN->param('save_query') ) { + if ( $IN->cookie('query_10') ) { # delete the oldest query + + for (1..9) { + push @COOKIES, $IN->cookie( + -name => 'query_' . $_, + -value => $IN->cookie('query_' . ($_+1) ), + -path => "/", + -expires => '+1y' + ); + } + + my $redirect_url = + $CFG{'script_url'} + . "?$CFG{do}=" + . $IN->param( $CFG{do} ) + . '&data_source=' + . $IN->param('data_source') + . "&action=monitor&from_monitor=1&query=$query_esc"; + print $IN->redirect( + -url => $redirect_url, + -cookie => \@COOKIES + ); + + return; + } + else { # add the query to the last slot. + my $new_query; + for my $i ( 1 .. 10 ) { + if ( not $IN->cookie("query_$i") ) { + push @COOKIES, $IN->cookie( + -name => "query_$i", + -value => $IN->param('query'), + -path => "/", + -expires => '+1y' + ); + last; + } + } + my $redirect_url = + $CFG{'script_url'} + . "?$CFG{do}=" + . $IN->param( $CFG{do} ) + . '&data_source=' + . $IN->param('data_source') + . "&action=monitor&from_monitor=1&query=$query_esc"; + print $IN->redirect( + -url => $redirect_url, + -cookie => \@COOKIES + ); + + return; + } + } + elsif ( $IN->param('delete_query') ) { + + my @not_deleted_queries; + for my $i ( 1 .. 10 ) { + if ( !$IN->param("delete_query_$i") ) { + if ( !$IN->cookie("query_$i") ) { + push ( @not_deleted_queries, 0 ); + } + else { + push ( @not_deleted_queries, $IN->cookie("query_$i") ); + } + } + } + + for (1..10) { + push @COOKIES, $IN->cookie( + -name => 'query_' . $_, + -value => $not_deleted_queries[$_ - 1] || '', + -path => "/", + -expires => '+1y' + ); + } + + my $redirect_url = + $CFG{'script_url'} + . "?$CFG{do}=" + . $IN->param( $CFG{do} ) + . '&data_source=' + . $IN->param('data_source'); + + print $IN->redirect( + -url => $redirect_url, + -cookie => \@COOKIES + ); + + return; + } + } + + return 1; +} + +sub do_logout { +# ----------------------------------------------------------------------------- +# Logs the users out by making all the cookies used in +# the script expire. +# + cookie_cleanup(); + print $IN->header( -cookie => \@COOKIES ); + return html_logout( $IN ); +} + +sub cookie_cleanup { +# ----------------------------------------------------------------------------- +# Makes all cookies expire. +# + push @COOKIES, $IN->cookie( + -name => $CFG{'db_host_cookie_name'}, + -value => '', + -expires => '-1y', + -path => '/' + ); + push @COOKIES, $IN->cookie( + -name => $CFG{'db_user_cookie_name'}, + -value => '', + -expires => '-1y', + -path => '/' + ); + push @COOKIES, $IN->cookie( + -name => $CFG{'db_pass_cookie_name'}, + -value => '', + -expires => '-1y', + -path => '/' + ); + push @COOKIES, $IN->cookie( + -name => $CFG{'url_cookie_name'}, + -value => '', + -expires => '-1y', + -path => '/' + ); +} + +sub connect_db { +# ----------------------------------------------------------------------------- +# Tries to connect the database with user name and password +# provided first. If access denied then tries connecting +# again with user name and password undefined. If both +# fail then an login page will be prompted. + + + my ( $db, $db_host, $db_port, $username, $password, $message ); + my $data_source = $IN->param("data_source") || 'DBI:mysql:'; + my $init_login = $IN->param('init_login'); + my $cur_db = get_db( $IN->param('data_source') ) || '', + +# gets user data from cookies. + $username = $IN->cookie( $CFG{'db_user_cookie_name'} ) || ''; + $password = $IN->cookie( $CFG{'db_pass_cookie_name'} ) || ''; + $db_host = $IN->cookie( $CFG{'db_host_cookie_name'} ) || 'localhost'; + + my $db_connection = $IN->param("db_for_connection") || ''; + + if ($db_connection) { + $data_source = "DBI:mysql:" . $IN->param("db_for_connection"); + } + +# while under demo mode, check if the user is using the host specified and make sure +# the script only connect to the database specified. + + + if ( $db_host && ( $data_source eq 'DBI:mysql:' ) ) { + $data_source = "DBI:mysql:host=$db_host"; + } + else { $data_source = $data_source . ":$db_host" } + +# set connect info to the info specified in the config file if direct_connect is on. + if ( $CFG{'direct_connect'} ) { + $db = $CFG{'direct_db'}; + $username = $CFG{'direct_user'}; + $password = $CFG{'direct_pass'}; + $db_host = $CFG{'direct_host'}; + $db_port = $CFG{'direct_port'}; + + $data_source = "DBI:mysql:$db"; + if ($db_host) { $data_source .= ":$db_host"; } + if ($db_port) { $data_source .= ":$db_port"; } + } + +# while under demo mode, check if the user is using the database specified. + +# connects to mysql. + $DBH = DBI->connect( + "$data_source", + "$username", + "$password", + { + RaiseError => 0, + PrintError => 0, + AutoCommit => 1 + } + ); + + if ( not $DBH ) { + my $orig_error = $DBI::errstr; + +# If the connection fails then the user name and/or the password may be wrong or that they are correct but the +# the connection fail for some other reason + + if ( $DBI::errstr =~ m/(.ccess denied)/ ) + { # If the user name and/or the password is incorrect + $DBH = + DBI->connect( "$data_source", undef, undef, + { RaiseError => 0, PrintError => 0, AutoCommit => 1 } ) + or return sqlerr($orig_error); + } + elsif ( $DBI::errstr =~ m/(.nknown database)/ ) + { # database specified not existed + return sqlerr("$DBI::errstr."); + } + elsif (( $DBI::errstr =~ m/an't connect to/ ) + || ( $DBI::errstr =~ m/Unknown MySQL Server Host/ ) ) + { + return sqlerr("$DBI::errstr."); + } + else { cgierr("connection failed: $DBI::errstr"); } + } + return 1; +} + +sub exec_query { +# ----------------------------------------------------------------------------- +# Send the input qeury MySQL thru database handler. + + my $query = shift; + my ($sth); + + + $sth = $DBH->prepare($query) + or return sqlerr( \( GT::CGI->html_escape( $DBI::errstr ) . "

        Query: " . GT::CGI->html_escape( $query ) ) ); + $sth->execute() + or return sqlerr( \( GT::CGI->html_escape( $DBI::errstr ) . "

        Query: " . GT::CGI->html_escape( $query ) ) ); + + return $sth; +} + +sub sqlerr { +# ----------------------------------------------------------------------------- +# Error prompt. +# + my $error = shift; + my ( $message, $init_login ); + + $init_login = 0; + my $db_connection = $IN->param("db_for_connection") || ''; + +# If access denied, then a login page will be displayed. + if ( $DBI::errstr =~ m/(.ccess denied)/ ) { + $error = GT::CGI->html_escape( $error ); + $message = \"

        Permission to perform action denied!

        MySQL Said: $error

        Please enter your user name and password"; + my $args = $IN->get_hash; + if ( !keys %$args or ( $IN->param( $CFG{do} ) eq 'login' ) ) { + $message = 'Welcome! Please enter your log-in info.'; + + $init_login = 1; + } + elsif ( $IN->param('init_login') ) { + + $message = 'Login failed. Please enter another hostname/username/password.'; + $init_login = 1; + } + &html_login( $message, $init_login ); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return; + } + +# If connect error, login page is prompted to let the user to enter another +# host name. + elsif ( + ( $DBI::errstr =~ m/an't connect to/ ) + or ( $DBI::errstr =~ m/Unknown MySQL Server Host/ ) + ) + { + $message = qq~Connection to MySQL failed. + The hostname may be different or the server may be down. + Please enter a new hostname and try again.~; + my $args = $IN->get_hash; + if ( !keys %$args or ( $IN->param( $CFG{do} ) eq 'login' ) ) { + $message = 'Welcome! Please enter your log-in info.'; + + $init_login = 1; + } + elsif ( $IN->param('init_login') ) { + + $message = 'Login failed. Please enter another hostname/username/password.'; + $init_login = 1; + } + html_login( $message, $init_login ); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return; + } + +# database specified not existed + elsif ( $DBI::errstr =~ m/(.nknown database)/ ) { + if ( !$db_connection ) { + $message = "Connection to MySQL failed. A database name is needed for connection."; + html_login_dbname( $message, $init_login ); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return; + } + else { + $message = "Unknown database '$db_connection'. Please enter another database name."; + html_login_dbname( $message, $init_login ); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return; + } + } + +# display the error message. + else { + + if ( $CFG{'debug'} ) { + cgierr($error); + } + else { + html_sqlerr( $error ); + if ( $CFG{'debug'} ) { cgierr("debug"); } + return; + } + } +} + +sub html_display { +# ----------------------------------------------------------------------------- + my ( $page, $tags, $opts ) = @_; + + $tags ||= {}; + $opts ||= {}; + +# Populate the tags with frequently used values + my %extra_tags = ( + do => scalar $IN->param( $CFG{do} ), + do_param => $CFG{do}, + + home_url => $CFG{'home_url'}, + script_url => $CFG{'script_url'}, + version => $VERSION, + + data_source => scalar $IN->param('data_source'), + db => get_db( $IN->param('data_source') ) || '', + table => scalar $IN->param('table'), + + from_monitor => scalar $IN->param('from_monitor'), + action => scalar $IN->param('browse_action') || $IN->param('action'), + ); + for ( keys %extra_tags ) { + next if defined $tags->{$_}; + $tags->{$_} = $extra_tags{$_}; + } + +# Ensure required options have been defaulted + $opts->{print} = 1 unless defined $opts->{print}; + $opts->{escape} = 1 unless defined $opts->{escape}; + $opts->{root} ||= $CFG{template_dir}; + $opts->{dont_save} = $CFG{template_dont_save} unless defined $opts->{dont_save}; + +# If the parse call will print, need to print the CGI header + if ( $opts->{print} ) { + print $IN->header( + @COOKIES ? ( -cookies => \@COOKIES ) : () + ); + } + return GT::Template->parse( $page, $tags, $opts ); +} + +sub cgierr { +# ----------------------------------------------------------------------------- +# Displays any errors and prints out FORM and ENVIRONMENT +# information. Useful for debugging. +# + eval { local $SIG{__DIE__}; $IN = GT::CGI->new; }; + if ( defined $GT::CGI::PRINTED_HEAD ) { + print "Content-type: text/plain\n\n" unless ($GT::CGI::PRINTED_HEAD); + } + else { + print "Content-type: text/plain\n\n"; + } + + my ( $key, $env ); + my ( $error, $nolog ) = @_; + if ( $CFG{'debug'} ) { + print "\n\nDEBUG\n==========================================\n"; + } + else { + print + "\n\nCGI ERROR\n==========================================\n"; + } + $error and print "Error Message : $error\n"; + $0 and print "Script Location : $0\n"; + $] and print "Perl Version : $]\n"; + + print "\nConfiguration\n-------------------------------------------\n"; + foreach $key ( sort keys %CFG ) { + my $space = " " x ( 20 - length($key) ); + print "$key$space: $CFG{$key}\n"; + } + if ( $IN ) { + print "\nCookies\n-------------------------------------------\n"; + print "$CFG{'db_user_cookie_name'} : " + . $IN->cookie( $CFG{'db_user_cookie_name'} ); + print "\n$CFG{'db_pass_cookie_name'} : " + . $IN->cookie( $CFG{'db_pass_cookie_name'} ); + print "\n$CFG{'db_host_cookie_name'} : " + . $IN->cookie( $CFG{'db_host_cookie_name'} ); + print "\n$CFG{'url_cookie_name'} : " + . $IN->cookie( $CFG{'url_cookie_name'} ); + print "\nquery_1 : " . $IN->cookie('query_1'); + print "\nquery_2 : " . $IN->cookie('query_2'); + print "\nquery_3 : " . $IN->cookie('query_3'); + print "\nquery_4 : " . $IN->cookie('query_4'); + print "\nquery_5 : " . $IN->cookie('query_5'); + print "\nquery_6 : " . $IN->cookie('query_6'); + print "\nquery_7 : " . $IN->cookie('query_7'); + print "\nquery_8 : " . $IN->cookie('query_8'); + print "\nquery_9 : " . $IN->cookie('query_9'); + print "\nquery_10 : " . $IN->cookie('query_10'); + + print + "\n\nForm Variables\n-------------------------------------------\n"; + foreach $key ( sort $IN->param ) { + my $space = " " x ( 20 - length($key) ); + print "$key$space: " . $IN->param($key) . "\n"; + } + } + print + "\nEnvironment Variables\n-------------------------------------------\n"; + foreach $env ( sort keys %ENV ) { + my $space = " " x ( 20 - length($env) ); + print "$env$space: $ENV{$env}\n"; + } + print "\nStack Trace \n-------------------------------------------\n"; + my $i = 0; + while ( my ( $file, $line, $sub ) = ( caller( $i++ ) )[ 1, 2, 3 ] ) { + print qq!($sub) called from ($file) line ($line)
        \n!; + } + exit; +} + +sub check_libraries { +# ----------------------------------------------------------------------------- +# Required Librariers +# Make sure we are using perl 5.003 and load other required files. + + eval { + local $SIG{__DIE__}; + require DBI; + }; + if ($@) { + my $message = +"Error loading required libraries\n\nReason: $@\n\n1.\tIt's likely that you do not have the module installed.\n\tYou can find this at: http://www.perl.com/CPAN/modules/by-module/DBI/\n\n2.\tIf the file exists:\n\t"; + $message .= +qq~Please check if the path to the folder that contains the file is in \@INC. + +\t\@INC is a special variable in Perl that contains the list of places to +\tlook for Perl scripts to be evaluated by the do, require, or use +\tconstructs. The error occurs because DBI.pm cannot be found in \@INC. +\tPlease check if you have Perl installed properly and check if you have the +\tcorrect path to perl in the cgi. If you do, then please contact the +\tserver admin. +~; + library_error($message); + } + + eval { + local $SIG{__DIE__}; + require DBD::mysql; + }; + if ($@) { + my $message = +"Error loading required libraries\n\nReason: $@\n\n1.\tIt's likely that you do not have the module installed.\n\tYou can find this at: http://www.perl.com/CPAN/modules/by-module/DBD/\n\n2.\tIf the file exists:\n\t"; + $message .= +qq~Please check if the path to the folder that contains the file is in \@INC. + +\t\@INC is a special variable in Perl that contains the list of places to +\tlook for Perl scripts to be evaluated by the do, require, or use +\tconstructs. The error occurs because mysql.pm cannot be found in \@INC. +\tPlease check if you have Perl installed properly and check if you have the +\tcorrect path to perl in the cgi. If you do, then please contact the +\tserver admin. +~; + library_error($message); + } + eval { + local $SIG{__DIE__}; + require strict; + require 5.004; # We need at least Perl 5.004 + }; + if ($@) { + cgierr( +"MySQLMan requires at least perl version 5.004 or better. You are using: $[. ($@)" + ); + } + + eval { + local $SIG{__DIE__}; + require GT::CGI; + require GT::Base; + require GT::Template; + }; + if ($@) { + library_error( +"Error loading required libraries\n\nReason: $@\n\n1.\tPlease check if the file is in MySQLMan directory, permission is set correctly, and that it compiles.\n\n2.\tIf the file exists in the folder, then check if the path to MySQLMan folder is in \@INC.\n\tIf \@INC does not contain the path then add\n\t\tuse lib '/path/to/MySQLMan';\n\tto the beginning of mysql.cgi.\n\n\tPlease refer the comments in mysql.cgi for detail.\n\n3.\tPlease check if the file was uploaded in ASCII mode (instead of BINARY mode)." + ); + } +} + +sub library_error { +# ----------------------------------------------------------------------------- +# HTML error page. Displayed when there error occurred while +# loading required libraries. + + my ($message) = @_; + if ( defined $GT::CGI::PRINTED_HEAD ) { + print "Content-type: text/html\n\n" unless ($GT::CGI::PRINTED_HEAD); + } + else { + print "Content-type: text/html\n\n"; + } + print qq~ + + +MySQLMan - Error loading required libraries. + + + + + + + + + + + + +
        + + MySQLMan: Error loading required libraries. + +
        +
          +
          +            
          +$message
          +            
          +            
          +
        +
        + + + + +~; + + exit; +} + +# Was in html.pl +# Common Variables +# ----------------------------------------------------------------------------- +# home_url : the URL to home page. (Specified in mysql.cfg) +# script_url : the URL to mysql.cgi. (Specified in mysql.cfg) +# db : the name of current database. +# table : the name of current table. +# version : the current version of the script +# help_topic : help_topic for sub html_help +# + +sub html_database { +# ----------------------------------------------------------------------------- +# List of databases in MySQL. +# db_table : the table that contain the databases in MySQL +# together with "drop" links to drop databases. +# $feedback: feedback message of any action performed before +# arriving the page. + + my ( $data_source, $db_table, $feedback ) = @_; + html_display( + 'database.html', + { + db_table => $db_table, + db_table_cnt => scalar(@$db_table), + table => '', + feedback => $feedback, + help_topic => 'db_list', + } + ); +} + +sub html_table { +# ----------------------------------------------------------------------------- +# List of tables in the database selected. +# table_tables: the table that contains the table names in +# the database together with action links +# (browse/select/property/insert/empty/drop) +# $feedback : feedback message of any action performed before +# arriving the page. + + my ( $table_tables, $feedback ) = @_; + html_display( + 'table.html', + { + table_tables => $table_tables, + table_tables_cnt => scalar(@$table_tables), + table => '', + feedback => $feedback, + help_topic => "table_list", + } + ); +} + +sub html_table_browse { +# ----------------------------------------------------------------------------- +# This will display the result of any query that requires records to +# be displayed. +# page : the current page. +# page_jump : the input box that allows the user to go to any page. +# page_link : the links to prev/next/top page. +# col_name : the column names in the table. +# table_records: the table that contains the result of the query. +# query_printed: the query executed. +# total_rows : total number of rows resulted from the query. +# + my ( + $table, $page_jump, $page_link, + $col_name, $table_records, $query, $empty_set, + $pri_key, $query_printed, $total_rec_num, $save_search_link + ) = @_; + + html_display( + 'table_browse.html', + { + total_rows => $total_rec_num, + table => $table, + page => scalar $IN->param('page') || '1', + empty_set => $empty_set, + page_jump => $page_jump, + page_link => $page_link, + col_name => $col_name, + table_records => $table_records, + query => $query, + query_printed => $query_printed || $query, + pri_key => $pri_key, + help_topic => "browse", + save_search_link => $save_search_link + } + ); +} + +sub html_insert { +# ----------------------------------------------------------------------------- +# Insert new record. +# $form_fields: the input table that lets the user to enter +# values in to create a new record. +# $feedback : feedback message of any action performed before +# arriving the page. + + my ( $feedback ) = @_; + + my $table = $IN->param('table'); + if ( $CFG{'demo_mode'} ) { alias_name_check( $table ) or return; } + my ($form_fields, $form_hidden) = form_fields( 0, () ) or return; + + html_display( + 'insert.html', + { + insert_fields => $form_fields, + insert_fields_cnt => scalar(@$form_fields), + form_hidden => $form_hidden, + feedback => $feedback, + help_topic => "insert", + insert_null => $CFG{insert_null}, + } + ); +} + +sub html_update { +# ----------------------------------------------------------------------------- +# Edit record page. +# $insert_fields: the input table with original values of the record +# in the input fields. + my ( $insert_fields, $form_hidden ) = @_; + html_display( + 'edit.html', + { + insert_fields => $insert_fields, + insert_fields_cnt => scalar(@$insert_fields), + form_hidden => $form_hidden, + record_modify => scalar $IN->param('record_modify'), + page => scalar $IN->param('page') || 1, + action => scalar $IN->param('action'), + sort_index => scalar $IN->param('sort_index'), + fields => scalar $IN->param('fields'), + where => scalar $IN->param('where'), + example => scalar $IN->param('example'), + browse_action => scalar $IN->param('browse_action'), + help_topic => 'edit', + } + ); +} + +sub html_table_def { +# ----------------------------------------------------------------------------- +# lets the user to construct the specificaitons of fields/columns. +# Used when creating a new table or adding new field(s)/column(s). +# If a new table is to be created, the table name is first checked to +# see if it is a valid one. Then the number of fields/columns is checked +# also for its validity. +# $columns: the input table that lets user to construct field/column +# spec's. +# + my ( $action ) = @_; + my ($columns); + + if ( $action eq 'create' ) { $action = 'create_table'; } + else { $action = 'alter_table'; } + + valid_name_check( $IN->param('table') ) or return; + + if ( $IN->param('num_of_fields') < 1 ) { + sqlerr("Number of fields cannot be less than 0."); + } + elsif ( $IN->param('num_of_fields') > 500 ) { + sqlerr("Number of fields too large."); + } + else { + for ( my $i = 0 ; $i < $IN->param('num_of_fields') ; $i++ ) { + $columns .= html_display( + 'create_field.txt', + { + field_num => $i, + do_param => $CFG{do} + }, + { + print => 0 # don't print this + } + ); + } + + html_display( + 'create_table.html', + { + do => $action, + columns => \$columns, + num_of_fields => scalar $IN->param('num_of_fields'), + position => scalar $IN->param('position'), + help_topic => 'col_def', + } + ); + } +} + +sub html_alter_col { +# ----------------------------------------------------------------------------- +# Change field/column specification. +# col : the field/column name that's being changed. +# field : same as col. +# type : the original field/column type. +# null : either 'YES' or ''. +# default: the default value. +# extra : extra properties. (auto_increment) + + my ( $field, $type, $length_set, $attributes, $null, $default, $extra ) + = @_; + my ( $type_select, $null_select, $extra_select, $attribute_select ); + +# show the original field/column specs. + $type_select = ""; + + if ($attributes) { $attribute_select = "" } + + if ($null) { $null_select = '' } + else { $null_select = '' } + + if ($extra) { $extra_select = "" } + + html_display( + 'alter_col.html', + { + col => scalar $IN->param('col'), + field => $field, + type => $type, + length_set => $length_set, + attributes => $attributes, + null => $null, + default => $default, + extra => $extra, + type_select => \$type_select, + null_select => \$null_select, + extra_select => \$extra_select, + attribute_select => \$attribute_select, + help_topic => 'col_def_change', + } + ); +} + +sub html_page_jump { +# ----------------------------------------------------------------------------- +# displays a text input box that allow user to go to +# any page of the result table. +# pages: total number of pages of the result. +# + my ( $pages, $fields, $example, $index ) = @_; + html_display( + 'page_jump.txt', + { + pages => $pages, + fields => $fields, + where => scalar $IN->param('where'), + action => scalar $IN->param('action'), + sort_index => $index, + example => $example, + query => scalar $IN->param('query'), + }, + { print => 0 }, + ); +} + +sub html_confirm_action { +# ----------------------------------------------------------------------------- +# Confirmation page. +# $query: the actual query that is going to be executed. +# + my ( $query ) = @_; + + html_display( + 'confirm.html', + { + table => scalar $IN->param('table'), + action => scalar $IN->param('action'), + query => $query, + query_param => scalar $query, + col => scalar $IN->param('col'), + key_name => scalar $IN->param('key_name'), + redirect_url => scalar $IN->cookie( $CFG{'url_cookie_name'} ) + || $CFG{'script_url'}, + help_topic => 'confirm', + } + ); +} + +sub html_sqlerr { +# ----------------------------------------------------------------------------- +# Error message. +# error: the actual error message. + my ( $error ) = @_; + my $table = $IN->param('table'); + if ( ( $IN->param( $CFG{do} ) eq 'create' ) + || $IN->param('action') eq 'rename_table' ) + { + $table = ''; + } + + html_display( + 'sqlerr.html', + { + table => $table, + error => $error, + help_topic => 'sqlerr', + } + ); +} + +sub html_login { +# ----------------------------------------------------------------------------- +# Login page. The URL of the previous page is read in from cookie +# or the script URL is used if the cookie is not set. +# url : the URL to the previous page. +# user : Username. Read from cookie. +# pass : Password. Read from cookie. +# host : Host name. Used for database connection and is read from cookie. +# message: message displayed in the login page. +# + my ( $message, $init_login ) = @_; + my $url = $IN->cookie( $CFG{'url_cookie_name'} ) || $CFG{'script_url'}; + +# For Netscape. + $url =~ s/\;/&/g; + + if ( $url =~ m/\?/ ) { $url .= '&from_login=1' } + else { $url .= '?from_login=1' } + + html_display( + 'login.html', + { + url => $url, + user => scalar $IN->cookie( $CFG{'db_user_cookie_name'} ), + pass => scalar $IN->cookie( $CFG{'db_pass_cookie_name'} ), + host => scalar $IN->cookie( $CFG{'db_host_cookie_name'} ), + message => $message, + init_login => $init_login, + help_topic => 'login', + } + ); +} + +sub html_login_dbname { +# ----------------------------------------------------------------------------- +# Login page. The URL of the previous page is read in from cookie +# or the script URL is used if the cookie is not set. +# url : the URL to the previous page. +# user : Username. Read from cookie. +# pass : Password. Read from cookie. +# host : Host name. Used for database connection and is read from cookie. +# message: message displayed in the login page. +# + my ( $message, $init_login ) = @_; + my $url = $IN->cookie( $CFG{'url_cookie_name'} ) || $CFG{'script_url'}; + + html_display( + 'login_dbname.html', + { + url => $url, + message => $message, + init_login => $init_login, + help_topic => 'login_dbname', + } + ); +} + +sub html_logout { +# ----------------------------------------------------------------------------- +# Logout message. +# + html_display( + 'logout.html', + { + data_source => '', + table => '', + help_topic => 'logout', + version => $VERSION, + } + ); +} + +sub html_back { +# ----------------------------------------------------------------------------- +# The confirmation page that is displayed after login. +# url: the URL to the page before the login command is performed. + + + html_display( + 'login_back.html', + { + url => scalar $IN->param('url') || "$CFG{'script_url'}", + help_topic => 'login_back', + } + ); +} + +#=================================================# +# Top Level Operations # +#=================================================# + +sub html_create_db { +# ----------------------------------------------------------------------------- +# Create new database. +# + html_display( + 'op_create_db.html', + { help_topic => 'create_db' } + ); +} + +sub html_sql_monitor { +# ----------------------------------------------------------------------------- +# SQL monitor. +# $message: the feedback message from SQL monitor +# in the form "num_rows rows affacted" + my ( $message ) = @_; + +# build a table for queries saved. + my $query_table = build_saved_query_table(); + + html_display( + 'op_sql_monitor.html', + { + feedback => $message, + help_topic => 'sql_monitor', + version => $VERSION, + query_table => $query_table, + query_table_cnt => scalar(@$query_table), + } + ); +} + +sub html_create_table { +# ----------------------------------------------------------------------------- +# Create new table page. + + + html_display( + 'op_create_table.html', + { + table => '', + help_topic => 'create_table', + } + ); +} + +sub html_import { +# ----------------------------------------------------------------------------- +# Data import page. +# + my ( $options, $size ) = @_; + my $empty_op = ''; + my $empty; + + for ( my $i ; $i < $size ; $i++ ) { + $empty .= '' . "\n"; + } + + $size = $size + 1; + if ( $size > 10 ) { $size = 10; } + + html_display( + 'op_import.html', + { + field_options => \$options, + empty_options => \$empty, + size => $size, + help_topic => 'import', + } + ); +} + +sub html_export { +# ----------------------------------------------------------------------------- +# Data export page. +# + my ( $options, $size ) = @_; + my $empty_op = ''; + my $empty; + + for ( my $i ; $i < $size ; $i++ ) { + $empty .= '' . "\n"; + } + + $size = $size + 1; + if ( $size > 10 ) { $size = 10; } + html_display( + 'op_export.html', + { + field_options => \$options, + empty_options => \$empty, + size => $size, + help_topic => 'export', + } + ); +} + +sub html_save_search { +# ----------------------------------------------------------------------------- + html_display( + 'save_search.html', + { + insert_fields => '', + record_modify => scalar $IN->param('record_modify'), + page => scalar $IN->param('page') || 1, + action => scalar $IN->param('action'), + sort_index => scalar $IN->param('sort_index'), + fields => scalar $IN->param('fields'), + where => scalar $IN->param('where'), + example => scalar $IN->param('example'), + browse_action => scalar $IN->param('browse_action'), + help_topic => 'save_search_result', + version => $VERSION, + query => scalar $IN->param('query') + } + ); +} + +sub html_mysqldump { +# ----------------------------------------------------------------------------- +# Mysqldump page +# + + my $table_checkboxes = get_checkbox_tables_in_database() or return; + + html_display( + 'op_mysqldump.html', + { + tb_checkboxes => $table_checkboxes, + tb_checkboxes_cnt => scalar(@$table_checkboxes), + help_topic => 'sql_dump', + } + ); + +} + +sub html_add_fields { +# ----------------------------------------------------------------------------- +# Add field/column to table page. +# + + my $options_col_order = qq|\n\n|; + foreach my $col ( get_cols( $IN->param('table') ) ) { + $options_col_order .= + qq|\n|; + } + + html_display( + 'op_add_fields.html', + { + opt_col_order => \$options_col_order, + help_topic => 'add_col', + } + ); +} + +sub html_rename_table { +# ----------------------------------------------------------------------------- +# Rename table page. +# + html_display( + 'op_rename_table.html', + { help_topic => 'rename' } + ); +} + +#=================================================# +# Show SQL Monitor Query # +#=================================================# + +sub html_show_query { +# ----------------------------------------------------------------------------- + my $i = $IN->param('query_displayed'); + my $query = $IN->cookie("query_$i"); + $query =~ s/\n/
        \n/g; + + html_display( + 'show_query.html', + { + query => $query, + i => $i + } + ); +} + +#=================================================# +# Help Pages # +#=================================================# + +sub html_help { +# ----------------------------------------------------------------------------- + my $topic = $IN->param("help_topic"); + if ( $topic =~ /^\w+\.jpg$/ ) { + if (open( FH, "$CFG{template_dir}/help_$topic" )) { + binmode FH; + binmode STDOUT; + while ( read( FH, my $buf, 4096 ) ) { + print $buf; + } + close FH; + } + # else die? + } + else { + if ( $topic !~ /^\w+$/ ) { + sqlerr("Invalid help topic: $topic\n"); + } + html_display( + 'help_' . $topic . '.html', + ); + } +} + +#=================================================# +# Demo Prompt # +#=================================================# + +sub html_demo_prompt { +# ----------------------------------------------------------------------------- +# Demo message. It is displayed when demo mode is on and the action performed +# is disabled. +# + + my ( $demo_message ) = @_; + html_display( + 'demo_prompt.html', + { + demo_message => $demo_message, + help_topic => 'demo', + } + ); + return; +} + +1; + +__END__ + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/README b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/README new file mode 100644 index 0000000..9a3f02f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/README @@ -0,0 +1,296 @@ +# ================================================================== +# MySQLMan - web based MySQL manager. +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: README,v 1.4 2002/01/04 01:39:53 alex Exp $ +# +# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +# Redistribution in part or in whole strictly prohibited. +# ================================================================== +# +# COPYRIGHT NOTICE: +# +# Copyright 2000 Gossamer Threads Inc. All Rights Reserved. +# +# This program is being distributed as shareware. It may be used and +# modified free of charge for personal, academic or non-profit +# use, so long as this copyright notice and the header above remain intact. +# Any commercial use should be registered. Please also send me an email, +# and let me know where you are using this script. By using this program +# you agree to indemnify Gossamer Threads Inc. from any liability. +# +# Selling the code for this program without prior written consent is +# expressly forbidden. Obtain permission before redistributing this +# program over the Internet or in any other medium. In all cases +# copyright and header must remain intact. +# +# Please check the README file for full details on registration. +# ===================================================================== + +Revision History: + Jan 2, 2002: Version 1.09 Released + - Previous versions where bug fixes only released inside Links + SQL and Gossamer Mail + - Fixes template path problems many people have had. + Dec 28, 2000: Version 1.05 Released + - queries can now be saved in the SQL Monitor + - results of searches/browse can now be dumped to a file + or to a screen. + - revamped to use GT libs, and removed CGI.pm use + + Aug 31, 2000: version 1.04 Released + - made if possible to save results from browse/search(select) + to a delimited file. + - save query option implemented in SQL monitor + - modified insert so that the script supports older + versions of mySQL as well. + - made it optional to hide fields with type TIMESTAMP + - made it optional to confirm delete action + when deleting a single record. + - on the INSERT form, if the column type is a TEXT/BLOB, + + <%else%> + + <%endif%> + <%if insert_null%> + <%if nullable%> checked<%endif%>><%else%> <%endif%> + <%endif%> + + <%endloop%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login.html new file mode 100644 index 0000000..09f8efa --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login.html @@ -0,0 +1,36 @@ + + +MySQLMan: Login + + + + +
        + + MySQLMan: Login +
        +<%include header.txt%> +
          + + +
          + <%if message%><%message%><%endif%> +
          + + + + Host:
          +
          + Username:
          +
          + Password:
          +
          + Store Login Cookie: +
          +
          + +
          +
          +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_back.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_back.html new file mode 100644 index 0000000..7862b76 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_back.html @@ -0,0 +1,26 @@ + + +MySQLMan: Login Feedback + + + + +
        + + MySQLMan: Login Feedback +
        +<%include header.txt%> + +

        +

          + + Host name/User name/Password Stored.

          +You should be transferred to the page you were at automatically. If not +please click "Back" to go back. +

          +Back +

          +
        +
        + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_dbname.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_dbname.html new file mode 100644 index 0000000..05800e9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/login_dbname.html @@ -0,0 +1,29 @@ + + +MySQLMan: Login - Database name + + + + +
        + + MySQLMan: Login - Database name +
        +<%include header.txt%> +
          + + +
          + <%message%> +
          + + + + Database name:
          +
          + +
          +
          +
        +
        + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/logout.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/logout.html new file mode 100644 index 0000000..682e636 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/logout.html @@ -0,0 +1,21 @@ + + +MySQLMan: Logout + + + + +
        + + MySQLMan: Logout +
        +<%include header.txt%> + +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/message.txt b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/message.txt new file mode 100644 index 0000000..5641049 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/message.txt @@ -0,0 +1,14 @@ + + + + + + + + +
        + MySQL message: +
        + <%feedback%> +
        +
        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_add_fields.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_add_fields.html new file mode 100644 index 0000000..0e5aa65 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_add_fields.html @@ -0,0 +1,30 @@ + + +MySQLMan: Add Field(s) + + + + +
        + + MySQLMan: Add Field(s) +
        +<%include header.txt%> +
          +
          + + + + +
        • Add new field(s) to table <%table%> +
            Number of new fields to be added: + +
            +Position: +
          +

        • +
        +
        + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_db.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_db.html new file mode 100644 index 0000000..9d12751 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_db.html @@ -0,0 +1,24 @@ + + +MySQLMan: Create New Database + + + + +
        + + MySQLMan: Create New Database +
        +<%include header.txt%> +
          +
          + + + + Create a New Database: + +
          +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_table.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_table.html new file mode 100644 index 0000000..5bc36ef --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_create_table.html @@ -0,0 +1,34 @@ + + +MySQLMan: Create New Table + + + + +
        + + MySQLMan: Create New Table +
        +<%include header.txt%> +
          + + +
          +
          + + + * Create new table on database <%db%>
          +
            + Table name:
            +
            + Number of Fields:
            +
            + +
          +
          +
          + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_export.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_export.html new file mode 100644 index 0000000..71825f9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_export.html @@ -0,0 +1,120 @@ + + +MySQLMan: Export to File + + + + + + + +
        + + MySQLMan: Export to File +
        +<%include header.txt%> +
          + + +
          +
        • Export Data from Table <%table%>:
          +
            +
            + + + + + + Export to screen.
            + Export to file.   + Path:

            + + Select fields:
            + All fields
            + Selected Fields +

              +
            • Please note that in the exported file, the order of the data fields will follow the order of
              + fields selected here. +

              + <%include fields_selection.txt%> +

              +

            + + Options:
            + Fields: +
              + Delimiter:
              + Escape Character:
              +
            + Records: +
              + Delimiter:
              +
            +

            + +

            +
          +
        • + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_import.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_import.html new file mode 100644 index 0000000..a5f31b2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_import.html @@ -0,0 +1,145 @@ + + +MySQLMan: Import From File + + + + + + + +
        + + MySQLMan: Import From File +
        +<%include header.txt%> +
          + +
          +
        • Import Data to Table <%table%>:
          +
            +
            + + + + + + + + + + + + + + + + + +
            File on server.  Path:
            OR
            File on local drive.  Path:
            +

            + Select fields:
            + All fields
            + Selected Fields +

              +
            • Please note that the order should match the order of the fields in the file. +

              + <%include fields_selection.txt%> +

              +
            + + Local Import
            + Do not show error message if there are duplicate records and do the following:
            +
              + Ignore
              + Replace
              +
            + Fields: +
              + Delimiter:
              + Escape Character:
              +
            + Records: +
              + Delimiter:
              + Ignore first Lines +
            +

            + +

            +
          +
        • + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_mysqldump.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_mysqldump.html new file mode 100644 index 0000000..e3a0e90 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_mysqldump.html @@ -0,0 +1,155 @@ + + +MySQLMan: mysqldump + + + + +
        + + MySQLMan: SQL Dump - <%table%> +
        +<%include header.txt%> +
          +
          + + + + Dump to screen.
          + Dump to file. +  Path: +

          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          + Select tables:
          + Dump all tables in database <%db%>
          + Dump selected tables only
          +
          + +<%set select_cols = 5%> + + + <%loop tb_checkboxes%> + + <%unless last or row_num % $select_cols%> + + + <%endunless%> + <%if last and row_num % $select_cols%> + + <%endif%> + <%endloop%> + +
          + checked<%endif%>><%name%> +
          +   +
          +
          +   +
          + CREATE TABLE statements: +
          Write CREATE TABLE statements.
          + Options: +
          + Add a DROP TABLE IF EXISTS statement before each CREATE TABLE statement.
          + (--add-drop-table)
          + Do not write CREATE TABLE statements. +
          (--no-create-info) +
          +   +
          + INSERT statements: +
          + Write INSERT statements.
          + Options: +
          + + + Use INSERT statements that name each column to be inserted. +
          (--complete-insert) +
          + + + Write INSERT DELAYED statements. +
          (--delayed-insert) +
          + + + Write multiple-row INSERT statements. +
          (--extended-insert) +
          + Do not write table data. +
          (--no-data) +
          + + +

          +

          +

        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_rename_table.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_rename_table.html new file mode 100644 index 0000000..e0ef041 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_rename_table.html @@ -0,0 +1,26 @@ + + +MySQLMan: Rename table <%table%> + + + + +
        + + MySQLMan: Rename table <%table%> +
        +<%include header.txt%> +
          +
          + + + + + +
        • Rename table <%table%> to: + +
        • +

          +

        +
        + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_sql_monitor.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_sql_monitor.html new file mode 100644 index 0000000..64353f7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/op_sql_monitor.html @@ -0,0 +1,85 @@ + + +MySQLMan: SQL Monitor + + + + +
        + + MySQLMan: SQL Monitor +
        +<%include header.txt%> +
          +<%if feedback%> +<%include message.txt%> +<%endif%> +
          + +
        • Run SQL query/queries
          + (If running multiple queries, each query must start in a new line and end with a semi-colon (;).)
        • + + + + +
          + Save query
          + + +
          + +<%if query_table_cnt%> + + + + + + + + + + + + +<%loop query_table%> + + + + + + +<%endloop%> + +
          SAVED QUERYCOMPLETE QUERY
          <%partial_query%>
          Show
          +<%endif%> + +
          + +
        • Run queries saved in a file.
          + (Please note that all queries that require display would not be
          + displayed to the screen.)
        • + + + + + + + + + + + + + + + +
          File on server.  Path:
          OR
          File on local drive.  Path:
          + + + +
          + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/page_jump.txt b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/page_jump.txt new file mode 100644 index 0000000..4d31ca9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/page_jump.txt @@ -0,0 +1,12 @@ +

        + + + + + + + + + +Goto Page: of <%pages%> +

        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/property.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/property.html new file mode 100644 index 0000000..b3d2eed --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/property.html @@ -0,0 +1,62 @@ + + +MySQLMan: Table Property + + + + +
        + + MySQLMan: Table Property +
        +<%include header.txt%> +
          +<%if feedback%> +<%include message.txt%> +

          +<%endif%> + + + <%loop table_columns%> + + <%endloop%> + + <%loop table_property%> + + <%loop columns%> + + <%endloop%> + + + + + + + <%endloop%> +
          <%name%>ACTION +
          <%name%>ChangeDropPrimaryIndexUnique
          +

          +

            +<%if key_table_cnt%> +
          • Keys: + + + + + + + + <%loop key_table%> + + + + + + + <%endloop%> +
            Key nameUniqueFieldAction
            <%name%><%unique%><%column_name%>Drop
            +<%endif%> +
          +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/save_search.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/save_search.html new file mode 100644 index 0000000..393b140 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/save_search.html @@ -0,0 +1,57 @@ + + +MySQLMan: Save Search Result + + + + + +
        + + MySQLMan: Save Search Result +
        +<%include header.txt%> +
          + + +
          +
        • Save Search Result:
          +
            +
            + + + + + + + + + + + + + + Print to screen.
            + Export to file.   + Path:

            + + Options:
            + Fields: +

              + Delimiter:
              + Escape Character:
              +
            + Records: +
              + Delimiter:
              +
            +

            + +

            +
          +
        • + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/show_query.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/show_query.html new file mode 100644 index 0000000..ffb7644 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/show_query.html @@ -0,0 +1,19 @@ + + +MySQLMan: Complete Query (<%i%>) + + + + +
        + + MySQLMan: Complete Query (<%i%>) +
        +
          +
          + + +
          <%query%>
          +
        +
        + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/sqlerr.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/sqlerr.html new file mode 100644 index 0000000..262ccb8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/sqlerr.html @@ -0,0 +1,21 @@ + + +MySQLMan: ERROR + + + + +
        + + MySQLMan: ERROR +
        +<%include header.txt%> +

        + Error +

        MySQL said: <%error%>

        +Back + + +

        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table.html new file mode 100644 index 0000000..2ef9537 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table.html @@ -0,0 +1,46 @@ + + +MySQLMan: Table list + + + + +
        + + MySQLMan: Table list +
        +<%include header.txt%> +

        + +

          <%if feedback%> + <%include message.txt%> +

          + <%endif%> + <%if table_tables_cnt%> + + + <%loop table_tables%> + + + + + + + + + + <%endloop%> +
          TABLEACTIONRECORDS
          <%name%>BrowseSelectPropertiesInsertDropEmpty<%count%>
          + <%endif%> + + <%ifnot table_tables%> + + +
          There are no Tables in the Database
          + <%endif%> + +

        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_browse.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_browse.html new file mode 100644 index 0000000..2764b7d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_browse.html @@ -0,0 +1,76 @@ + + +MySQLMan: View Table <%table%> + + + + +
        + + MySQLMan: View Table <%table%> +
        +<%include header.txt%> + +<%if from_monitor%> +
          +

          +

          + * Run SQL query/queries
          + + + + +
          + +
          +

          +<%if total_rows%> +( <%total_rows%> rows affected ) +<%endif%> +

        +<%endif%> + +<%ifnot from_monitor%> + + + +
        SQL-query
        <%query_printed%>
        +

        +<%if total_rows%> +( <%total_rows%> records in total ) Save Result +<%endif%> +<%endif%> + + +<%page_jump%> +<%page_link%> +<%if empty_set%> + + +
        Empty Set
        +<%else%> + + + <%loop col_name%> + + <%endloop%> +<%if pri_key%> + +<%endif%> + +<%loop table_records%> + + <%loop record%> + + <%if pri_key and last%> + + + <%endif%> + <%endloop%> + +<%endloop%> +
        <%if link%><%endif%><%name%><%if link%><%endif%>
        <%if null and show_null%>NULL<%elsif name eq ''%> <%else%><%name%><%endif%>Edit onClick="return confirm('Delete the record?')"<%endif%>>Delete
        +<%endif%> +<%page_link%> +

        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_select.html b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_select.html new file mode 100644 index 0000000..b896afd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/mysqlman/templates/table_select.html @@ -0,0 +1,68 @@ + + +MySQLMan: Search + + + + +
        + + MySQLMan: Search +
        +<%include header.txt%> + +
          + + +
          +
          + + + + + +SELECT: +<%set select_cols = 5%> + + + <%loop select_table%> + + <%unless last or row_num % $select_cols%> + + + <%endunless%> + <%if last and row_num % $select_cols%> + + <%endif%> + <%endloop%> + +
          + checked<%endif%>><%name%> +
          +   +
          +

          +Where:
          +

          +Do a "query by example" (wildcard: "%"):
          + + + + + + + <%loop example_table%> + + + + + + <%endloop%> +
          FieldsTypeValue
          <%name%><%type%>
          +

          +

          +
          + +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-1.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-1.cgi new file mode 100755 index 0000000..0fe49e3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-1.cgi @@ -0,0 +1,1028 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: nph-build.cgi,v 1.96 2009/05/09 17:01:33 brewt 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. +# ================================================================== + +# Notes about build changed +# ------------------------- +# The only pages which are built conditionally are the detailed pages (if enabled) +# and the category pages. Detailed pages and category pages are built when the +# Timestmp column of the Links and Category tables are newer the last_build time. +# Because of this, you should not make any full table changes to the Links and +# Category data as it will lead to build_changed unnecessarily re-building all the +# pages. + +# Load Time::HiRes if available for better time checking. +# Must appear here, or we get strange errors. +BEGIN { eval { require Time::HiRes; import Time::HiRes qw/time/; }; } + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use vars qw/$USE_HTML $TIME_START $TOTAL_TIME @CARP_NOT $GRAND_TOTAL/; +use Links qw/:objects :payment/; +use Links::Build; +use GT::File::Tools qw/mkpath dirname/; +use Carp; + +@CARP_NOT = 'GT::Plugins'; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { +# ------------------------------------------------------------------- +# Determine what we should build. +# + +# Reset the total so it's re-calculated for a build in persistent environments + $GRAND_TOTAL = undef; + +# Let other parts of the code know that we're building static pages right now + $STASH{building_static} = 1; + + $USE_HTML = defined $ENV{REQUEST_METHOD} ? 1 : 0; + if ($USE_HTML) { + my $do = $IN->param('do') || ''; + if ($do eq 'changed') { build_changed() } + elsif ($do eq 'staggered') { build_staggered() } + elsif ($do eq 'repair') { build_repair() } + else { build_all() } + } + else { + my $arg = $ARGV[0] || ''; + if ($arg eq '--all') { build_all() } + elsif ($arg eq '--changed') { build_changed() } + elsif ($arg eq '--repair') { build_repair() } + elsif ($arg eq '--flags') { build_flags() } + else { usage() } + } +} + +sub build_all { +# ------------------------------------------------------------------ +# Rebuild the entire directory. +# + + + _header("Building All Links.", "Gossamer Links is now converting your entire directory into a series of HTML pages."); + +# Create backup file. + _build_backup(); + +# Update isNew, isCool, isPopular flags. + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + +# Build Home Page. + $PLG->dispatch('create_home', \&_build_home, {}); + +# Build New Page. + $PLG->dispatch('create_new', \&_build_new, {}); + +# Build Cool Page. + $PLG->dispatch('create_cool', \&_build_cool, {}); + +# Build Ratings Page. + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + +# Build Detailed Page. + $PLG->dispatch('create_detailed', \&_build_detailed, {}); + +# Build Category Pages. + $PLG->dispatch('create_category', \&_build_category, {}); + + _footer(); + + $CFG->{last_build} = time; + $CFG->save; +} + +sub build_changed { +# ------------------------------------------------------------------ +# Rebuild only changed pages. +# + my $unix_time = $CFG->{last_build} ? $CFG->{last_build} : time; + Links::init_date(); + my $time = GT::Date::date_get($unix_time - $CFG->{date_offset} * 3600, '%yyyy%-%mm%-%dd% %HH%:%MM%:%ss%'); + + + _header("Building Links Changed Since $time", "Gossamer Links is now updating your main pages, and any category or detailed pages that have changed since you last built."); + +# Build Changed Detailed Page. + require GT::SQL::Condition; + $CFG->{debug_level} = 1; + $PLG->dispatch('create_detailed_changed', \&_build_detailed, GT::SQL::Condition->new('Links.ID', '=', 2527)); #[503,613,775,918,959,1246,1446,2564])); + _footer(); + $CFG->{debug_level} = 0; + return; + +# Do any backups. + _build_backup(); + +# Update isNew, isCool, isPopular flags. + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + +# Build Home Page. + $PLG->dispatch('create_home', \&_build_home, {}); + +# Build New Page. + $PLG->dispatch('create_new', \&_build_new, {}); + +# Build Cool Page. + $PLG->dispatch('create_cool', \&_build_cool, {}); + +# Build Ratings Page. + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + +# Build Changed Detailed Page. + $PLG->dispatch('create_detailed_changed', \&_build_detailed, GT::SQL::Condition->new('Links.Timestmp', '>', $time)); + +# Build Changed Category Pages. + $PLG->dispatch('create_category_changed', \&_build_category, GT::SQL::Condition->new('Timestmp', '>', $time)); + _footer(); + + $CFG->{last_build} = time; + $CFG->save; +} + +sub build_staggered { +# ------------------------------------------------------------------ +# Rebuild all, but stagger over multiple requests. +# + my $stage = $IN->param('s') || 1; + + my $start_time = $IN->param('started') || time; + + + if ($stage == 1) { + _header( + "Building Staggered: Creating backup file.", + "Gossamer Links is now creating a backup file that you can use to restore your directory in case of emergency.", + "nph-build.cgi?do=staggered&s=2&started=$start_time", + $start_time + ); + _build_backup(); + _footer(); + } + elsif ($stage == 2) { + _header( + "Building Staggered: Updating Link Flags.", + "Gossamer Links is now updating the new, changed and popular flags.", + "nph-build.cgi?do=staggered&s=3&started=$start_time", + $start_time + ); + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + _footer(); + } + elsif ($stage == 3) { + _header( + "Building Staggered: Build Home, New, Cool.", + "Gossamer Links is now updating your main pages.", + "nph-build.cgi?do=staggered&s=4&started=$start_time", + $start_time + ); + $PLG->dispatch('create_home', \&_build_home, {}); + $PLG->dispatch('create_new', \&_build_new, {}); + $PLG->dispatch('create_cool', \&_build_cool, {}); + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + _footer(); + } + elsif ($stage == 4 and $CFG->{build_detailed}) { + my $count = $DB->table($CFG->{build_detail_format} eq '%ID%' ? 'Links' : ('Links', 'Category', 'CatLinks'))->count; + my $page = $IN->param('p') || 1; + my $offset = $IN->param('o') || 500; + my $total = int($count / $offset); + $total++ if $count % $offset or !$total; + _header( + "Building Detailed Pages: Page $page of $total", + "Gossamer Links is now updating your detailed pages.", + "nph-build.cgi?do=staggered&started=$start_time&s=" . ($page >= $total ? 5 : "4&p=" . ($page+1) . "&o=$offset"), + $start_time + ); + $PLG->dispatch('create_detailed_staggered', \&_build_detailed, { page => $page, limit => $offset }); + _footer(); + } + elsif ($stage == 5 or $stage == 4 and !$CFG->{build_detailed}) { + my $db = $DB->table('Category'); + my $count = $db->count; + my $page = $IN->param('p') || 1; + my $offset = $IN->param('o') || 10; + my $total = int($count / $offset); + $total++ if $count % $offset; + $total or $total++; + _header( + "Building Categories: Page $page of $total", + "Gossamer Links is now rebuilding your category pages.", + "nph-build.cgi?do=staggered&started=$start_time&s=" . ($page >= $total ? '6' : "5&p=" . ($page + 1) . "&o=$offset"), + $start_time + ); + $PLG->dispatch('create_category_staggered', \&_build_category, { page => $page, offset => $offset }); + _footer(); + } + elsif ($stage == 6) { + _header( + "Building Staggered: All Done", + "Gossamer Links has finished converting your directory to HTML pages.", + undef, + $start_time + ); + print "All pages have been successfully updated.\n\n"; + _footer(); + $CFG->{last_build} = time; + $CFG->save; + } +} + +sub build_repair { +# ------------------------------------------------------------------ +# Repair tables. +# + + + _header( + "Repairing tables.", + "Gossamer Links is now ensuring that your category counts are correct." + ); + _reset_sequences(); + _reset_expired_links(); + _build_catlinks_orphan_check(); + _reset_category_stats(); + _build_reset_hits(); + _build_orphan_check(); + _build_new_flags({ reset => 1 }); + _build_changed_flags({ reset => 1 }); + _build_cool_flags(); + _footer(); +} + +sub build_flags { +# ------------------------------------------------------------------ +# Reset flags. +# + + + _header( + "Resetting flags.", + "Gossamer Links is now going to reset the new, cool, and popular flags." + ); + _build_new_flags({ reset => 1 }); + _build_changed_flags({ reset => 1 }); + _build_cool_flags(); + _footer(); +} + +sub usage { +# ------------------------------------------------------------------ +# Return a usage statement if called from shell. +# + print <{build_use_backup}) { + print "Creating backup file... skipped\n\n"; + return; + } + _time_start(); + print "Creating backup file...\n"; + require Links::Import::S2BK; + + my $max_keep = 7; + my $root = $CFG->{admin_root_path} . '/backup'; + my $filename = 'BACKUP'; + + for my $n (reverse 0 .. $max_keep) { + my $oldname = join '.', $filename, $n || (); + my $newname = join '.', $filename, $n+1; + if (-e "$root/$oldname") { + rename "$root/$oldname", "$root/$newname" or print "\tCouldn't rename '$root/$oldname' -> '$root/$newname': $!"; + } + } + Links::Import::S2BK::import({ source => "$CFG->{admin_root_path}/defs", destination => "$root/$filename", delimiter => "\t" }, sub { print "\n\tWARNING: @_\n" }, sub { die @_ }, sub { print "\n\tWARNING: @_\n" }, sub { }); + _display_time(); +} + +sub _build_home { +# ------------------------------------------------------------------ +# Generate the home page. +# + _time_start(); + + my $index = $CFG->{build_home} || $CFG->{build_index}; + my $page = "$CFG->{build_root_path}/$index"; + print $USE_HTML + ? qq'Building Home Page...\n' + : qq'Building Home Page...\n'; + + my $fh = _open_write($page); + print $fh Links::Build::build(home => {}); + close $fh; + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + _display_time(); +} + +sub _build_new { +# ------------------------------------------------------------------ +# Generate the what's new listings. +# + _time_start(); + +# We are either generating a single html page, or an index and follow up pages. + my $page = $CFG->{build_new_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_new_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? qq|Building What's New Index...\n| + : qq|Building What's New Index...\n|; + + if ($CFG->{build_span_pages}) { + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_index => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Now let's build any sub pages. + my $db = $DB->table('Links'); + $db->select_options("GROUP BY Add_Date"); + my $sth = $db->select(Add_Date => 'COUNT(*)', { isNew => 'Yes' }, VIEWABLE); + while (my ($date, $count) = $sth->fetchrow_array) { + $date =~ s/\s(.*)//; + $page = $CFG->{build_new_path} . "/" . $date . $CFG->{build_extension}; + $url = $CFG->{build_new_url} . "/" . $date . $CFG->{build_extension}; + print $USE_HTML + ? "\tBuilding Subpage: $date..." + : "\tBuilding Subpage: $date..."; + + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($count / $lpp); + $num_pages++ if $count % $lpp; + +# Print the main page. + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_subpage => { date => $date, nh => 1, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Print the sub pages. + for my $i (2 .. $num_pages) { + $page = "$CFG->{build_new_path}/${date}_$i$CFG->{build_extension}"; + $url = "$CFG->{build_new_url}/${date}_$i$CFG->{build_extension}"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_subpage => { date => $date, nh => $i, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + print $USE_HTML + ? qq|$i | + : "$i "; + } + print " $count links okay.\n"; + } + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(new => {}); + } + + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + _display_time(); + +} + +sub _build_cool { +# ------------------------------------------------------------------ +# Generate the what's cool listings. +# + _time_start(); + + my $page = $CFG->{build_cool_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_cool_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? "Building What's Cool Index..." + : "Building What's Cool Index..."; + +# If we are spanning pages. + if ($CFG->{build_span_pages}) { + + my $db = $DB->table('Links'); + my $total = $db->count({ isPopular => 'Yes' }, VIEWABLE); + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($total / $lpp); + $num_pages++ if $total % $lpp; + $num_pages ||= 1; + + for my $i (1 .. $num_pages) { + if ($i > 1) { + $page = $CFG->{build_cool_path} . "/$CFG->{build_more}$i$CFG->{build_extension}"; + $url = $CFG->{build_cool_url} . "/$CFG->{build_more}$i$CFG->{build_extension}"; + } + { + my $fh = _open_write($page); + print $fh Links::Build::build(cool => { nh => $i, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod($perms, $page); + print $USE_HTML + ? "$i " + : "$i "; + } + print $USE_HTML ? "
        " : "\n"; + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(cool => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + _display_time(); +} + +sub _build_ratings { +# ------------------------------------------------------------------ +# Generate the ratings page. +# + _time_start(); + + my $page = $CFG->{build_ratings_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_ratings_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? qq|Building Top Rated...\n| + : "Building Top Rated...\n"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(rating => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + _display_time(); +} + +sub _build_detailed { +# ------------------------------------------------------------------ +# Generate one html page per link. +# + require Links::Tools; + + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{limit}; + } + else { + $cond = shift; + } + unless ($CFG->{build_detailed}) { + print "Skipping Detailed Build (disabled).\n\n"; + return; + } + + _time_start(); + + print "Building Detailed pages...\n"; + +# Only build validated links + $cond ||= GT::SQL::Condition->new; + $cond->add(VIEWABLE); + +# Loop through, building 1000 at a time + my ($limit, $offset, $count, $second_pass) = (1000, 0, 0); + my $rel = $DB->table(qw/Links CatLinks Category/); + print "\t"; + + my $Links = $DB->table('Links'); + while () { +# Links can be in multiple categories, make sure their detailed pages are only built once + $rel->select_options("GROUP BY LinkID") if $CFG->{build_detail_format} eq '%ID%'; + $rel->select_options("ORDER BY LinkID"); + + if ($cust_page or $cust_limit) { + last if $second_pass++; + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1) * $cust_limit); + } + else { + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $limit, $offset*$limit); + } + my %links_cols = %{$Links->cols}; + # Only select Category columns that don't conflict with Links columns. + my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols}; + + my $sth = $rel->select('Links.*', @cat_cols, 'CategoryID' => $cond); + + last unless $sth->rows; + + while (my $link = $sth->fetchrow_hashref) { + my $format = $Links->detailed_url($link); + my $page = "$CFG->{build_detail_path}/$format"; + my $url = "$CFG->{build_detail_url}/$format"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(detailed => $link); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + $USE_HTML ? + print qq'$link->{ID} ' : + print "$link->{ID} "; + print "\n\t" if ++$count % 20 == 0; + } + $offset++; + } + print "\n"; + _display_time(); +} + +sub _build_category { +# ------------------------------------------------------------------ +# Generate the category pages. +# + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{offset}; + $cond = {}; + } + else { + $cond = shift; + } + + _time_start(); + + print "Building Category pages...\n\n"; + + my $Cat = $DB->table('Category'); + my $CatLinks = $DB->table('Links', 'CatLinks'); + + $Cat->select_options('ORDER BY Full_Name'); + if (defined $cust_page and $cust_limit) { + $Cat->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1)*$cust_limit); + } + my $sth = $Cat->select(ID => Full_Name => $cond); + while (my ($id, $name) = $sth->fetchrow_array) { + my $clean_name = $Cat->as_url($name); + my $page = $CFG->{build_root_path} . "/" . $clean_name . '/' . $CFG->{build_index}; + my $url = $CFG->{build_root_url} . "/" . $clean_name . '/' . $CFG->{build_index}; + print $USE_HTML + ? "\tBuilding category $name...\n" + : "\tBuilding category $name...\n"; + my $total = $CatLinks->count({ 'CatLinks.CategoryID' => $id }, VIEWABLE); + print "\t\tLinks: $total\n"; + +# Do sub-pages if requested. + if ($CFG->{build_span_pages}) { + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($total / $lpp); + $num_pages++ if $total % $lpp; + +# Create the main page. + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => 1, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Create the sub pages. + for (2 .. $num_pages) { + $page = "$CFG->{build_root_path}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + $url = "$CFG->{build_root_url}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + print "\t\tBuilding subpage: " . ($USE_HTML + ? "$_\n" + : "$_\n" + ); + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => $_, mh => $lpp }); + } + chmod $perms, $page; + } + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + print "\tDone\n\n"; + } + _display_time("Finished building categories"); +} + +sub _build_reset_hits { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Resetting hits and rates...\n"; + my $ret = Links::Build::build(reset_hits => shift || {}); + _display_time(); + return $ret; +} + +sub _build_orphan_check { +# ------------------------------------------------------------------ +# Check for orphan links. +# + _time_start(); + print "Checking for orphan links...\n"; + my @orphans = Links::Build::build(orphan_check => { select => ['Title', 'ID'] }); + if (@orphans) { + print "\tThere are " . @orphans . " links that are not in a category. Please modify or delete the following links"; + if ($USE_HTML) { + print qq| (
        |; + my $i; + for (@orphans) { + $i++; + print qq||; + } + print qq|
        )|; + } + print ":\n"; + my $Links = $DB->table('Links'); + for my $link (@orphans) { + print "\t\t$link->{ID}: $link->{Title}"; + if ($USE_HTML) { + print qq~ - modify | delete\n~; + } + } + } + _display_time(); +} + +sub _build_catlinks_orphan_check { +# ------------------------------------------------------------------ +# Check for orphaned CatLinks entries. +# + _time_start(); + print "Checking for orphaned CatLinks entries...\n"; + my @orphans = Links::Build::build('catlinks_orphan_check'); + if (@orphans) { + print "\tThere are " . @orphans . " CatLinks entries where there are no associated link or category... "; + # Do some hackery to get a non-subclassed CatLinks table + #my $catlinks = $DB->table('CatLinks'); + my $catlinks = GT::SQL::Table->new( + name => $DB->prefix . 'CatLinks', + connect => $DB->{connect}, + debug => $DB->{_debug}, + _err_pkg => 'GT::SQL::Table' + ); + for (@orphans) { + $catlinks->delete($_); + } + print "Fixed.\n"; + } + _display_time(); +} + +sub _build_new_flags { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Updating new flags...\n"; + my $ret = Links::Build::build(new_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_changed_flags { +# ------------------------------------------------------------------ +# Updates the isChanged flags. +# + _time_start(); + print "Updating changed flags...\n"; + my $ret = Links::Build::build(changed_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_cool_flags { +# ------------------------------------------------------------------ +# Updates the What's Cool flags. +# + _time_start(); + print "Updating Cool Flags...\n"; + my $ret = Links::Build::build(cool_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _reset_sequences { +# ------------------------------------------------------------------ +# Reset postgres sequences after an import. +# + return 1 unless lc $DB->driver eq 'pg'; + _time_start(); + print "Resetting sequences...\n"; + my $p = $DB->prefix; + $DB->table('Category')->do_query("SELECT SETVAL('${p}Category_seq', MAX(ID)) FROM ${p}Category"); + $DB->table('Links')->do_query("SELECT SETVAL('${p}Links_seq', MAX(ID)) FROM ${p}Links"); + _display_time(); +} + +sub _reset_expired_links { +# ----------------------------------------------------------------------------- +# Updates link expiries to FREE when the expired_is_free option is turned on +# + return unless $CFG->{payment}->{enabled} and $CFG->{payment}->{expired_is_free}; + + my $force = $IN->param('force'); + + _time_start(); + print "Checking for optional, expired links to update to free...\n"; + + my $payment_mode = $CFG->{payment}->{mode} == REQUIRED ? [GLOBAL, REQUIRED] : REQUIRED; + my @req_cats = $DB->table('Category')->select(ID => { Payment_Mode => $payment_mode })->fetchall_list; + + # All links in non-required-payment categories need to be changed to be free links. + my @to_free = $DB->table('CatLinks', 'Links')->select(ID => GT::SQL::Condition->new( + ExpiryDate => '<' => time, + isValidated => '=' => 'Yes', + GT::SQL::Condition->new(CategoryID => 'IN' => \@req_cats)->not + ))->fetchall_list; + + if (@to_free) { + print "\tFound " . @to_free . " links to update..."; + $DB->table('Links')->update({ LinkExpired => \'ExpiryDate' }, { ID => \@to_free }); + $DB->table('Links')->update({ ExpiryDate => FREE, ExpiryCounted => 0 }, { ID => \@to_free }); + print " ok!\n"; + } + elsif ($force) { + print "\tNo links needed updating\n"; + } + + _display_time(); +} + +sub _reset_category_stats { +# ------------------------------------------------------------------ +# Reset category stats. +# + _time_start(); + print "Checking category stats...\n"; + + my $cat_db = $DB->table('Category'); + my $cat_link = $DB->table('CatLinks', 'Links', 'Category'); + my $force = $IN->param('force'); + + $cat_db->indexing(0); + my $root_cat = $cat_db->select(qw/ID Full_Name Number_of_Links Direct_Links/ => { FatherID => 0 }); + while (my ($root_id, $root_name, $nol, $dl) = $root_cat->fetchrow_array) { + my ($total, $direct) = _link_count($cat_link, $root_id, $root_name); + if ($force or $total != $nol or $direct != $dl) { + print $force ? + "\tUpdating $root_name counters..." : + "\tCategory $root_name should have $total/$direct total/direct links, but is set to $nol/$dl, repairing... "; + my ($new_nol, $new_dl) = _fix_category_stats($cat_db, $cat_link, $root_name, $root_id); + if ($new_nol != $total or $new_dl != $direct) { + print "Structure Error!\n"; + _check_category_struc($cat_db, $cat_link, $root_id, $root_name); + } + else { + print "$new_nol/$new_dl ok!\n"; + } + } + } + $cat_db->indexing(1); + _display_time(); +} + +sub _check_category_struc { +# ------------------------------------------------------------------ +# Find out where the problem is in a category with the wrong link count. +# + my ($cat_db, $cat_link, $root_id, $root_name) = @_; + my $sth = $cat_db->select( + ID => Full_Name => GT::SQL::Condition->new('Full_Name', 'Like', "$root_name/%") + ); + while (my ($child_id, $child_name) = $sth->fetchrow) { + my $cat_info = $cat_db->get($child_id, 'HASH', ['ID', 'Full_Name', 'Number_of_Links']); + my $total = _link_count($cat_link, $child_id, $child_name); + if ($total ne $cat_info->{Number_of_Links}) { + print "\t\t$cat_info->{Full_Name} reported: $cat_info->{Number_of_Links} real: $total\n"; + } + } +} + +sub _fix_category_stats { +# ------------------------------------------------------------------ +# Fix category counts. +# + my ($cat_db, $cat_link, $root_name, $root_id) = @_; + $cat_db->select_options('ORDER BY Full_Name DESC'); + my $sth = $cat_db->select(qw/ID Full_Name/ => GT::SQL::Condition->new(Full_Name => LIKE => "$root_name/%")); + + my $link_cond = GT::SQL::Condition->new( + CategoryID => '=' => $root_id, + VIEWABLE + ); + my (%count, %seen, %direct_count); + my $count = $cat_link->count($link_cond); + $count{$root_name} = $direct_count{$root_name} = $count; + + while (my ($id, $name) = $sth->fetchrow_array) { + $seen{$name}++ and print "Duplicate Category Name: ($id) $name\n" and next; + + $link_cond = GT::SQL::Condition->new( + CategoryID => '=' => $id, + VIEWABLE + ); + + my $count = $cat_link->count($link_cond); + $direct_count{$name} = $count; + $count{$name} += $count; + if ($count) { + my @uplevel = split /\//, $name; + for (0 .. $#uplevel - 1) { + my $up_name = join '/', @uplevel[0 .. $_]; + $count{$up_name} += $count; + } + } + } + while (my ($name, $count) = each %count) { + my $res = $cat_db->update({ Number_of_Links => $count, Direct_Links => $direct_count{$name} }, { Full_Name => $name }); + } + + return ($count{$root_name}, $direct_count{$root_name}); +} + +sub _link_count { +# ------------------------------------------------------------------ +# Given a Category => CatLinks => Links relation, a category ID, and a category +# name, returns the calculated Number_of_Links value in scalar context, or, in +# list context, the calculated Number_of_Links value and the calculated +# Direct_Links value. +# + my ($cat_link, $cat_id, $cat_name) = @_; + + my $child_links = $cat_link->count( + GT::SQL::Condition->new( + Full_Name => LIKE => "$cat_name/%", + VIEWABLE + ) + ); + my $direct_links = $cat_link->count( + GT::SQL::Condition->new( + CategoryID => '=' => $cat_id, + VIEWABLE + ) + ); + + return wantarray ? ($child_links + $direct_links, $direct_links) : ($child_links + $direct_links); +} + +sub _time_start { +# ------------------------------------------------------------------ +# Start a timer. +# + $TIME_START = time; +} + +sub _display_time { +# ------------------------------------------------------------------ +# Return time results. +# + my $message = shift || 'Done'; + printf "%s (%.2fs)\n\n", $message, time - $TIME_START; +} + +sub _header { +# ------------------------------------------------------------------ +# Print intro. +# + my ($msg, $msg2, $refresh, $started) = @_; + my $time = scalar localtime; + + $refresh ||= ''; + $TOTAL_TIME = $started || time; + $refresh &&= ""; + if ($USE_HTML) { + print $IN->header(-nph => $CFG->{nph_headers}); + print < + +$refresh +Building HTML Pages + +BUILDING + print Links::header("Building HTML Pages: $msg", $msg2, 0); + print <Started at $time. + +STARTED + } + else { + print "Started at $time.\n\nBuilding HTML pages...\n\n"; + } +} + +sub _footer { +# ------------------------------------------------------------------ +# Print the footer. +# + my $end = time; + my $elapsed = sprintf "%.2f", $end - $TOTAL_TIME; + + print "All done. Total time: (${elapsed}s)\n"; + print "
        " if $USE_HTML; +} + +sub _open_write { +# ----------------------------------------------------------------------------- +# Opens a file for writing (overwriting anything already there), and returns a +# filehandle reference. Dies with a more user-friendly error then Links::fatal +# if the open fails. Can take a second argument which, if true, will cause the +# function _not_ to attempt to make the containing directory. +# + my ($page, $nomkdir) = @_; + unless ($nomkdir) { + mkpath(dirname($page), oct $CFG->{build_dir_per}); + } + my $fh = \do { local *FH; *FH }; + open $fh, "> $page" and return $fh; + + my $error = "$!"; + my $user = eval { getpwuid($>) } || 'webserver'; + if ($error =~ /permission/i) { + print "\n\nERROR: Unable to open '$page': $error\n\n"; + if (-e $page) { + print <param('do') || ''; + if ($do eq 'changed') { build_changed() } + elsif ($do eq 'staggered') { build_staggered() } + elsif ($do eq 'repair') { build_repair() } + else { build_all() } + } + else { + my $arg = $ARGV[0] || ''; + if ($arg eq '--all') { build_all() } + elsif ($arg eq '--changed') { build_changed() } + elsif ($arg eq '--repair') { build_repair() } + elsif ($arg eq '--flags') { build_flags() } + else { usage() } + } +} + +sub build_all { +# ------------------------------------------------------------------ +# Rebuild the entire directory. +# + + + _header("Building All Links.", "Gossamer Links is now converting your entire directory into a series of HTML pages."); + +# Create backup file. + _build_backup(); + +# Update isNew, isCool, isPopular flags. + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + +# Build Home Page. + $PLG->dispatch('create_home', \&_build_home, {}); + +# Build New Page. + $PLG->dispatch('create_new', \&_build_new, {}); + +# Build Cool Page. + $PLG->dispatch('create_cool', \&_build_cool, {}); + +# Build Ratings Page. + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + +# Build Detailed Page. + $PLG->dispatch('create_detailed', \&_build_detailed, {}); + +# Build Category Pages. + $PLG->dispatch('create_category', \&_build_category, {}); + + _footer(); + + $CFG->{last_build} = time; + $CFG->save; +} + +sub build_changed { +# ------------------------------------------------------------------ +# Rebuild only changed pages. +# + my $unix_time = $CFG->{last_build} ? $CFG->{last_build} : time; + Links::init_date(); + my $time = GT::Date::date_get($unix_time - $CFG->{date_offset} * 3600, '%yyyy%-%mm%-%dd% %HH%:%MM%:%ss%'); + + + _header("Building Links Changed Since $time", "Gossamer Links is now updating your main pages, and any category or detailed pages that have changed since you last built."); + +# Do any backups. + _build_backup(); + +# Update isNew, isCool, isPopular flags. + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + +# Build Home Page. + $PLG->dispatch('create_home', \&_build_home, {}); + +# Build New Page. + $PLG->dispatch('create_new', \&_build_new, {}); + +# Build Cool Page. + $PLG->dispatch('create_cool', \&_build_cool, {}); + +# Build Ratings Page. + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + +# Build Changed Detailed Page. + $PLG->dispatch('create_detailed_changed', \&_build_detailed, GT::SQL::Condition->new('Links.Timestmp', '>', $time)); + +# Build Changed Category Pages. + $PLG->dispatch('create_category_changed', \&_build_category, GT::SQL::Condition->new('Timestmp', '>', $time)); + _footer(); + + $CFG->{last_build} = time; + $CFG->save; +} + +sub build_staggered { +# ------------------------------------------------------------------ +# Rebuild all, but stagger over multiple requests. +# + my $stage = $IN->param('s') || 1; + + my $start_time = $IN->param('started') || time; + + + if ($stage == 1) { + _header( + "Building Staggered: Creating backup file.", + "Gossamer Links is now creating a backup file that you can use to restore your directory in case of emergency.", + "nph-build.cgi?do=staggered&s=2&started=$start_time", + $start_time + ); + _build_backup(); + _footer(); + } + elsif ($stage == 2) { + _header( + "Building Staggered: Updating Link Flags.", + "Gossamer Links is now updating the new, changed and popular flags.", + "nph-build.cgi?do=staggered&s=3&started=$start_time", + $start_time + ); + _build_reset_hits(); + _build_new_flags(); + _build_changed_flags(); + _build_cool_flags(); + _footer(); + } + elsif ($stage == 3) { + _header( + "Building Staggered: Build Home, New, Cool.", + "Gossamer Links is now updating your main pages.", + "nph-build.cgi?do=staggered&s=4&started=$start_time", + $start_time + ); + $PLG->dispatch('create_home', \&_build_home, {}); + $PLG->dispatch('create_new', \&_build_new, {}); + $PLG->dispatch('create_cool', \&_build_cool, {}); + $PLG->dispatch('create_ratings', \&_build_ratings, {}); + _footer(); + } + elsif ($stage == 4 and $CFG->{build_detailed}) { + my $count = $DB->table($CFG->{build_detail_format} eq '%ID%' ? 'Links' : ('Links', 'Category', 'CatLinks'))->count; + my $page = $IN->param('p') || 1; + my $offset = $IN->param('o') || 500; + my $total = int($count / $offset); + $total++ if $count % $offset or !$total; + _header( + "Building Detailed Pages: Page $page of $total", + "Gossamer Links is now updating your detailed pages.", + "nph-build.cgi?do=staggered&started=$start_time&s=" . ($page >= $total ? 5 : "4&p=" . ($page+1) . "&o=$offset"), + $start_time + ); + $PLG->dispatch('create_detailed_staggered', \&_build_detailed, { page => $page, limit => $offset }); + _footer(); + } + elsif ($stage == 5 or $stage == 4 and !$CFG->{build_detailed}) { + my $db = $DB->table('Category'); + my $count = $db->count; + my $page = $IN->param('p') || 1; + my $offset = $IN->param('o') || 10; + my $total = int($count / $offset); + $total++ if $count % $offset; + $total or $total++; + _header( + "Building Categories: Page $page of $total", + "Gossamer Links is now rebuilding your category pages.", + "nph-build.cgi?do=staggered&started=$start_time&s=" . ($page >= $total ? '6' : "5&p=" . ($page + 1) . "&o=$offset"), + $start_time + ); + $PLG->dispatch('create_category_staggered', \&_build_category, { page => $page, offset => $offset }); + _footer(); + } + elsif ($stage == 6) { + _header( + "Building Staggered: All Done", + "Gossamer Links has finished converting your directory to HTML pages.", + undef, + $start_time + ); + print "All pages have been successfully updated.\n\n"; + _footer(); + $CFG->{last_build} = time; + $CFG->save; + } +} + +sub build_repair { +# ------------------------------------------------------------------ +# Repair tables. +# + + + _header( + "Repairing tables.", + "Gossamer Links is now ensuring that your category counts are correct." + ); + _reset_sequences(); + _reset_expired_links(); + _build_catlinks_orphan_check(); + _reset_category_stats(); + _build_reset_hits(); + _build_orphan_check(); + _build_new_flags({ reset => 1 }); + _build_changed_flags({ reset => 1 }); + _build_cool_flags(); + _footer(); +} + +sub build_flags { +# ------------------------------------------------------------------ +# Reset flags. +# + + + _header( + "Resetting flags.", + "Gossamer Links is now going to reset the new, cool, and popular flags." + ); + _build_new_flags({ reset => 1 }); + _build_changed_flags({ reset => 1 }); + _build_cool_flags(); + _footer(); +} + +sub usage { +# ------------------------------------------------------------------ +# Return a usage statement if called from shell. +# + print <{build_use_backup}) { + print "Creating backup file... skipped\n\n"; + return; + } + _time_start(); + print "Creating backup file...\n"; + require Links::Import::S2BK; + + my $max_keep = 7; + my $root = $CFG->{admin_root_path} . '/backup'; + my $filename = 'BACKUP'; + + for my $n (reverse 0 .. $max_keep) { + my $oldname = join '.', $filename, $n || (); + my $newname = join '.', $filename, $n+1; + if (-e "$root/$oldname") { + rename "$root/$oldname", "$root/$newname" or print "\tCouldn't rename '$root/$oldname' -> '$root/$newname': $!"; + } + } + Links::Import::S2BK::import({ source => "$CFG->{admin_root_path}/defs", destination => "$root/$filename", delimiter => "\t" }, sub { print "\n\tWARNING: @_\n" }, sub { die @_ }, sub { print "\n\tWARNING: @_\n" }, sub { }); + _display_time(); +} + +sub _build_home { +# ------------------------------------------------------------------ +# Generate the home page. +# + _time_start(); + + my $index = $CFG->{build_home} || $CFG->{build_index}; + my $page = "$CFG->{build_root_path}/$index"; + print $USE_HTML + ? qq'Building Home Page...\n' + : qq'Building Home Page...\n'; + + my $fh = _open_write($page); + print $fh Links::Build::build(home => {}); + close $fh; + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + _display_time(); +} + +sub _build_new { +# ------------------------------------------------------------------ +# Generate the what's new listings. +# + _time_start(); + +# We are either generating a single html page, or an index and follow up pages. + my $page = $CFG->{build_new_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_new_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? qq|Building What's New Index...\n| + : qq|Building What's New Index...\n|; + + if ($CFG->{build_span_pages}) { + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_index => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Now let's build any sub pages. + my $db = $DB->table('Links'); + $db->select_options("GROUP BY Add_Date"); + my $sth = $db->select(Add_Date => 'COUNT(*)', { isNew => 'Yes' }, VIEWABLE); + while (my ($date, $count) = $sth->fetchrow_array) { + $date =~ s/\s(.*)//; + $page = $CFG->{build_new_path} . "/" . $date . $CFG->{build_extension}; + $url = $CFG->{build_new_url} . "/" . $date . $CFG->{build_extension}; + print $USE_HTML + ? "\tBuilding Subpage: $date..." + : "\tBuilding Subpage: $date..."; + + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($count / $lpp); + $num_pages++ if $count % $lpp; + +# Print the main page. + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_subpage => { date => $date, nh => 1, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Print the sub pages. + for my $i (2 .. $num_pages) { + $page = "$CFG->{build_new_path}/${date}_$i$CFG->{build_extension}"; + $url = "$CFG->{build_new_url}/${date}_$i$CFG->{build_extension}"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(new_subpage => { date => $date, nh => $i, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + print $USE_HTML + ? qq|$i | + : "$i "; + } + print " $count links okay.\n"; + } + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(new => {}); + } + + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + _display_time(); + +} + +sub _build_cool { +# ------------------------------------------------------------------ +# Generate the what's cool listings. +# + _time_start(); + + my $page = $CFG->{build_cool_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_cool_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? "Building What's Cool Index..." + : "Building What's Cool Index..."; + +# If we are spanning pages. + if ($CFG->{build_span_pages}) { + + my $db = $DB->table('Links'); + my $total = $db->count({ isPopular => 'Yes' }, VIEWABLE); + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($total / $lpp); + $num_pages++ if $total % $lpp; + $num_pages ||= 1; + + for my $i (1 .. $num_pages) { + if ($i > 1) { + $page = $CFG->{build_cool_path} . "/$CFG->{build_more}$i$CFG->{build_extension}"; + $url = $CFG->{build_cool_url} . "/$CFG->{build_more}$i$CFG->{build_extension}"; + } + { + my $fh = _open_write($page); + print $fh Links::Build::build(cool => { nh => $i, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod($perms, $page); + print $USE_HTML + ? "$i " + : "$i "; + } + print $USE_HTML ? "
        " : "\n"; + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(cool => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + _display_time(); +} + +sub _build_ratings { +# ------------------------------------------------------------------ +# Generate the ratings page. +# + _time_start(); + + my $page = $CFG->{build_ratings_path} . "/" . $CFG->{build_index}; + my $url = $CFG->{build_ratings_url} . "/" . $CFG->{build_index}; + + print $USE_HTML + ? qq|Building Top Rated...\n| + : "Building Top Rated...\n"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(rating => {}); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + _display_time(); +} + +sub _build_detailed { +# ------------------------------------------------------------------ +# Generate one html page per link. +# + require Links::Tools; + + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{limit}; + } + else { + $cond = shift; + } + unless ($CFG->{build_detailed}) { + print "Skipping Detailed Build (disabled).\n\n"; + return; + } + + _time_start(); + + print "Building Detailed pages...\n"; + +# Only build validated links + $cond ||= GT::SQL::Condition->new; + $cond->add(VIEWABLE); + +# Loop through, building 1000 at a time + my ($limit, $offset, $count, $second_pass) = (1000, 0, 0); + my $rel = $DB->table(qw/Links CatLinks Category/); + print "\t"; + + my $Links = $DB->table('Links'); + while () { +# Links can be in multiple categories, make sure their detailed pages are only built once + $rel->select_options("GROUP BY LinkID") if $CFG->{build_detail_format} eq '%ID%'; + $rel->select_options("ORDER BY LinkID"); + + if ($cust_page or $cust_limit) { + last if $second_pass++; + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1) * $cust_limit); + } + else { + $rel->select_options(sprintf "LIMIT %d OFFSET %d", $limit, $offset*$limit); + } + my %links_cols = %{$Links->cols}; + # Only select Category columns that don't conflict with Links columns. + my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols}; + + my $sth = $rel->select('Links.*', @cat_cols, 'CategoryID' => $cond); + + last unless $sth->rows; + + while (my $link = $sth->fetchrow_hashref) { + my $format = $Links->detailed_url($link); + my $page = "$CFG->{build_detail_path}/$format"; + my $url = "$CFG->{build_detail_url}/$format"; + + { + my $fh = _open_write($page); + print $fh Links::Build::build(detailed => $link); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + + $USE_HTML ? + print qq'$link->{ID} ' : + print "$link->{ID} "; + print "\n\t" if ++$count % 20 == 0; + } + $offset++; + } + print "\n"; + _display_time(); +} + +sub _build_category { +# ------------------------------------------------------------------ +# Generate the category pages. +# + my ($cond, $cust_page, $cust_limit); + if (ref $_[0] eq 'HASH') { + $cust_page = $_[0]->{page}; + $cust_limit = $_[0]->{offset}; + $cond = {}; + } + else { + $cond = shift; + } + + _time_start(); + + print "Building Category pages...\n\n"; + + my $Cat = $DB->table('Category'); + my $CatLinks = $DB->table('Links', 'CatLinks'); + + $Cat->select_options('ORDER BY Full_Name'); + if (defined $cust_page and $cust_limit) { + $Cat->select_options(sprintf "LIMIT %d OFFSET %d", $cust_limit, ($cust_page-1)*$cust_limit); + } + my $sth = $Cat->select(ID => Full_Name => $cond); + while (my ($id, $name) = $sth->fetchrow_array) { + my $clean_name = $Cat->as_url($name); + my $page = $CFG->{build_root_path} . "/" . $clean_name . '/' . $CFG->{build_index}; + my $url = $CFG->{build_root_url} . "/" . $clean_name . '/' . $CFG->{build_index}; + print $USE_HTML + ? "\tBuilding category $name...\n" + : "\tBuilding category $name...\n"; + my $total = $CatLinks->count({ 'CatLinks.CategoryID' => $id }, VIEWABLE); + print "\t\tLinks: $total\n"; + +# Do sub-pages if requested. + if ($CFG->{build_span_pages}) { + my $lpp = $CFG->{build_links_per_page} || 25; + my $num_pages = int($total / $lpp); + $num_pages++ if $total % $lpp; + +# Create the main page. + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => 1, mh => $lpp }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + +# Create the sub pages. + for (2 .. $num_pages) { + $page = "$CFG->{build_root_path}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + $url = "$CFG->{build_root_url}/$clean_name/$CFG->{build_more}$_$CFG->{build_extension}"; + print "\t\tBuilding subpage: " . ($USE_HTML + ? "$_\n" + : "$_\n" + ); + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id, nh => $_, mh => $lpp }); + } + chmod $perms, $page; + } + } + else { + { + my $fh = _open_write($page); + print $fh Links::Build::build(category => { id => $id }); + } + my $perms = oct $CFG->{build_file_per}; + chmod $perms, $page; + } + print "\tDone\n\n"; + } + _display_time("Finished building categories"); +} + +sub _build_reset_hits { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Resetting hits and rates...\n"; + my $ret = Links::Build::build(reset_hits => shift || {}); + _display_time(); + return $ret; +} + +sub _build_orphan_check { +# ------------------------------------------------------------------ +# Check for orphan links. +# + _time_start(); + print "Checking for orphan links...\n"; + my @orphans = Links::Build::build(orphan_check => { select => ['Title', 'ID'] }); + if (@orphans) { + print "\tThere are " . @orphans . " links that are not in a category. Please modify or delete the following links"; + if ($USE_HTML) { + print qq| (
        |; + my $i; + for (@orphans) { + $i++; + print qq||; + } + print qq|
        )|; + } + print ":\n"; + my $Links = $DB->table('Links'); + for my $link (@orphans) { + print "\t\t$link->{ID}: $link->{Title}"; + if ($USE_HTML) { + print qq~ - modify | delete\n~; + } + } + } + _display_time(); +} + +sub _build_catlinks_orphan_check { +# ------------------------------------------------------------------ +# Check for orphaned CatLinks entries. +# + _time_start(); + print "Checking for orphaned CatLinks entries...\n"; + my @orphans = Links::Build::build('catlinks_orphan_check'); + if (@orphans) { + print "\tThere are " . @orphans . " CatLinks entries where there are no associated link or category... "; + # Do some hackery to get a non-subclassed CatLinks table + #my $catlinks = $DB->table('CatLinks'); + my $catlinks = GT::SQL::Table->new( + name => $DB->prefix . 'CatLinks', + connect => $DB->{connect}, + debug => $DB->{_debug}, + _err_pkg => 'GT::SQL::Table' + ); + for (@orphans) { + $catlinks->delete($_); + } + print "Fixed.\n"; + } + _display_time(); +} + +sub _build_new_flags { +# ------------------------------------------------------------------ +# Updates the What's New flags. +# + _time_start(); + print "Updating new flags...\n"; + my $ret = Links::Build::build(new_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_changed_flags { +# ------------------------------------------------------------------ +# Updates the isChanged flags. +# + _time_start(); + print "Updating changed flags...\n"; + my $ret = Links::Build::build(changed_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _build_cool_flags { +# ------------------------------------------------------------------ +# Updates the What's Cool flags. +# + _time_start(); + print "Updating Cool Flags...\n"; + my $ret = Links::Build::build(cool_flags => shift || {}); + _display_time(); + return $ret; +} + +sub _reset_sequences { +# ------------------------------------------------------------------ +# Reset postgres sequences after an import. +# + return 1 unless lc $DB->driver eq 'pg'; + _time_start(); + print "Resetting sequences...\n"; + my $p = $DB->prefix; + $DB->table('Category')->do_query("SELECT SETVAL('${p}Category_seq', MAX(ID)) FROM ${p}Category"); + $DB->table('Links')->do_query("SELECT SETVAL('${p}Links_seq', MAX(ID)) FROM ${p}Links"); + _display_time(); +} + +sub _reset_expired_links { +# ----------------------------------------------------------------------------- +# Updates link expiries to FREE when the expired_is_free option is turned on +# + return unless $CFG->{payment}->{enabled} and $CFG->{payment}->{expired_is_free}; + + my $force = $IN->param('force'); + + _time_start(); + print "Checking for optional, expired links to update to free...\n"; + + my $payment_mode = $CFG->{payment}->{mode} == REQUIRED ? [GLOBAL, REQUIRED] : REQUIRED; + my @req_cats = $DB->table('Category')->select(ID => { Payment_Mode => $payment_mode })->fetchall_list; + + # All links in non-required-payment categories need to be changed to be free links. + my @to_free = $DB->table('CatLinks', 'Links')->select(ID => GT::SQL::Condition->new( + ExpiryDate => '<' => time, + isValidated => '=' => 'Yes', + GT::SQL::Condition->new(CategoryID => 'IN' => \@req_cats)->not + ))->fetchall_list; + + if (@to_free) { + print "\tFound " . @to_free . " links to update..."; + $DB->table('Links')->update({ LinkExpired => \'ExpiryDate' }, { ID => \@to_free }); + $DB->table('Links')->update({ ExpiryDate => FREE, ExpiryCounted => 0 }, { ID => \@to_free }); + print " ok!\n"; + } + elsif ($force) { + print "\tNo links needed updating\n"; + } + + _display_time(); +} + +sub _reset_category_stats { +# ------------------------------------------------------------------ +# Reset category stats. +# + _time_start(); + print "Checking category stats...\n"; + + my $cat_db = $DB->table('Category'); + my $cat_link = $DB->table('CatLinks', 'Links', 'Category'); + my $force = $IN->param('force'); + + $cat_db->indexing(0); + my $root_cat = $cat_db->select(qw/ID Full_Name Number_of_Links Direct_Links/ => { FatherID => 0 }); + while (my ($root_id, $root_name, $nol, $dl) = $root_cat->fetchrow_array) { + my ($total, $direct) = _link_count($cat_link, $root_id, $root_name); + if ($force or $total != $nol or $direct != $dl) { + print $force ? + "\tUpdating $root_name counters..." : + "\tCategory $root_name should have $total/$direct total/direct links, but is set to $nol/$dl, repairing... "; + my ($new_nol, $new_dl) = _fix_category_stats($cat_db, $cat_link, $root_name, $root_id); + if ($new_nol != $total or $new_dl != $direct) { + print "Structure Error!\n"; + _check_category_struc($cat_db, $cat_link, $root_id, $root_name); + } + else { + print "$new_nol/$new_dl ok!\n"; + } + } + } + $cat_db->indexing(1); + _display_time(); +} + +sub _check_category_struc { +# ------------------------------------------------------------------ +# Find out where the problem is in a category with the wrong link count. +# + my ($cat_db, $cat_link, $root_id, $root_name) = @_; + my $sth = $cat_db->select( + ID => Full_Name => GT::SQL::Condition->new('Full_Name', 'Like', "$root_name/%") + ); + while (my ($child_id, $child_name) = $sth->fetchrow) { + my $cat_info = $cat_db->get($child_id, 'HASH', ['ID', 'Full_Name', 'Number_of_Links']); + my $total = _link_count($cat_link, $child_id, $child_name); + if ($total ne $cat_info->{Number_of_Links}) { + print "\t\t$cat_info->{Full_Name} reported: $cat_info->{Number_of_Links} real: $total\n"; + } + } +} + +sub _fix_category_stats { +# ------------------------------------------------------------------ +# Fix category counts. +# + my ($cat_db, $cat_link, $root_name, $root_id) = @_; + $cat_db->select_options('ORDER BY Full_Name DESC'); + my $sth = $cat_db->select(qw/ID Full_Name/ => GT::SQL::Condition->new(Full_Name => LIKE => "$root_name/%")); + + my $link_cond = GT::SQL::Condition->new( + CategoryID => '=' => $root_id, + VIEWABLE + ); + my (%count, %seen, %direct_count); + my $count = $cat_link->count($link_cond); + $count{$root_name} = $direct_count{$root_name} = $count; + + while (my ($id, $name) = $sth->fetchrow_array) { + $seen{$name}++ and print "Duplicate Category Name: ($id) $name\n" and next; + + $link_cond = GT::SQL::Condition->new( + CategoryID => '=' => $id, + VIEWABLE + ); + + my $count = $cat_link->count($link_cond); + $direct_count{$name} = $count; + $count{$name} += $count; + if ($count) { + my @uplevel = split /\//, $name; + for (0 .. $#uplevel - 1) { + my $up_name = join '/', @uplevel[0 .. $_]; + $count{$up_name} += $count; + } + } + } + while (my ($name, $count) = each %count) { + my $res = $cat_db->update({ Number_of_Links => $count, Direct_Links => $direct_count{$name} }, { Full_Name => $name }); + } + + return ($count{$root_name}, $direct_count{$root_name}); +} + +sub _link_count { +# ------------------------------------------------------------------ +# Given a Category => CatLinks => Links relation, a category ID, and a category +# name, returns the calculated Number_of_Links value in scalar context, or, in +# list context, the calculated Number_of_Links value and the calculated +# Direct_Links value. +# + my ($cat_link, $cat_id, $cat_name) = @_; + + my $child_links = $cat_link->count( + GT::SQL::Condition->new( + Full_Name => LIKE => "$cat_name/%", + VIEWABLE + ) + ); + my $direct_links = $cat_link->count( + GT::SQL::Condition->new( + CategoryID => '=' => $cat_id, + VIEWABLE + ) + ); + + return wantarray ? ($child_links + $direct_links, $direct_links) : ($child_links + $direct_links); +} + +sub _time_start { +# ------------------------------------------------------------------ +# Start a timer. +# + $TIME_START = time; +} + +sub _display_time { +# ------------------------------------------------------------------ +# Return time results. +# + my $message = shift || 'Done'; + printf "%s (%.2fs)\n\n", $message, time - $TIME_START; +} + +sub _header { +# ------------------------------------------------------------------ +# Print intro. +# + my ($msg, $msg2, $refresh, $started) = @_; + my $time = scalar localtime; + + $refresh ||= ''; + $TOTAL_TIME = $started || time; + $refresh &&= ""; + if ($USE_HTML) { + print $IN->header(-nph => $CFG->{nph_headers}); + print < + +$refresh +Building HTML Pages + +BUILDING + print Links::header("Building HTML Pages: $msg", $msg2, 0); + print <Started at $time. + +STARTED + } + else { + print "Started at $time.\n\nBuilding HTML pages...\n\n"; + } +} + +sub _footer { +# ------------------------------------------------------------------ +# Print the footer. +# + my $end = time; + my $elapsed = sprintf "%.2f", $end - $TOTAL_TIME; + + print "All done. Total time: (${elapsed}s)\n"; + print "
        " if $USE_HTML; +} + +sub _open_write { +# ----------------------------------------------------------------------------- +# Opens a file for writing (overwriting anything already there), and returns a +# filehandle reference. Dies with a more user-friendly error then Links::fatal +# if the open fails. Can take a second argument which, if true, will cause the +# function _not_ to attempt to make the containing directory. +# + my ($page, $nomkdir) = @_; + unless ($nomkdir) { + mkpath(dirname($page), oct $CFG->{build_dir_per}); + } + my $fh = \do { local *FH; *FH }; + open $fh, "> $page" and return $fh; + + my $error = "$!"; + my $user = eval { getpwuid($>) } || 'webserver'; + if ($error =~ /permission/i) { + print "\n\nERROR: Unable to open '$page': $error\n\n"; + if (-e $page) { + print <param('emailsto') : shift(@ARGV); + unless ($Is_CGI or $ID) { + print "Usage: $0 mailing_id + +$0 will attempt to send all the e-mails associated with that ID.\n"; + exit 1; + } + unless (defined $ID and length $ID) { + die "No Mailing ID passed to nph-email!"; + } + my $mail = $DB->table('MailingIndex')->select({ Mailing => $ID })->fetchrow_hashref; + if (! $mail) { + die "Invalid Mailing ID passed to nph-email!"; + } + my %mail = %$mail; + my $presend = sub { Links::user_page ('', \%info, { string => $_[1] }) }; + my $sent = 0; + $extra = $DB->table('MailingIndex')->select({ Mailing => $ID },['extra'])->fetchrow_array; + my $success = sub { + print ++$sent % 20 ? ". " : ". $sent sent
        \n"; + $DB->table('EmailMailings')->update({ 'Sent' => 1 }, { ID => shift }); + }; + my $faults = 0; + my $failure = sub { + $faults++; + my $mailID = shift; + my $sentstr = " . " x $sent; + print "\nThere was an error while sending the email to "; + print $DB->table('EmailMailings')->select({ ID => $mailID },['Email'])->fetchrow_arrayref()->[0]; + $DB->table('EmailMailings')->update({ 'Sent' => 1 }, { ID => $mailID }); + print "\n"; + print $sentstr; + }; +# BulkMail won't encode the name or subject for us. However, since we don't +# know what character set the input is, this will assume (actually +# GT::Mail::Parts::encode_mimewords) that the character set is iso-8859-1. + if ($mail{name} !~ /\x20-\x7e/) { + require GT::Mail::Parts; + $mail{name} = GT::Mail::Parts::encode_mimewords($mail{name}); + } + if ($mail{subject} !~ /\x20-\x7e/) { + require GT::Mail::Parts; + $mail{subject} = GT::Mail::Parts::encode_mimewords($mail{subject}); + } + my $mailer = GT::Mail::BulkMail->new( + -show_errors => 1, + -from => $mail{mailfrom}, + -name => $mail{name}, + -subject => $mail{subject}, + -message => $mail{message}, + -success => $success, + -failure => $failure, + -text => $mail{messageformat} eq 'text', + -html => $mail{messageformat} eq 'html', + -sendmail => $CFG->{db_mail_path}, + -smtp => $CFG->{db_smtp_server}, + ); + if (!$extra or $extra ne 'none') { + $mailer->subjectpresend($presend); + $mailer->messagepresend($presend); + } + my $get_cols = ['ID','Email']; + push @$get_cols, 'LinkID' if $extra and $extra eq 'Links'; + my $sth = $DB->table('EmailMailings')->select($get_cols => { Mailing => $ID, Sent => 0 }); + my $next = sub { + my @row = $sth->fetchrow_array; + return unless @row; + get_info(@row); + return @row; + }; + + my $start = time(); + my $started = scalar localtime; + + print $IN->header(-nph => $CFG->{nph_headers}); + if ($Is_CGI) { + print < + +Sending Emails + +@{[Links::header ('Sending Emails ...', 'Gossamer Links is now going to send the emails in the associated mailing. Please be patient, this can take a while depending on the speed of the mail server and the number of recipients.')]} +
        Started at $started.
        +
        +Sending emails ...
        +
        +HTML
        +    }
        +    else {
        +        print <send($next);
        +    my $finished = time;
        +    $DB->table('MailingIndex')->update({ done => int($finished) }, { Mailing => $ID });
        +    print "$sent sent.";# if $sent % 20;
        +    printf ("\n\nMailing complete (%.2f s)\n\n", $finished - $start);
        +    print $Is_CGI ? "
        \n" : "\n"; + print qq{Return to View Mailings + +} if $Is_CGI; +} + +sub get_info { +# ------------------------------------------------------------------- +# get_info sets %info with substitution information for a mailing ID. +# Substitution information is always set for the 'Users' table, as well as +# whatever is set in the table in the mailing index's 'index' field. +# Takes two arguments: The mailing ID for the MailingIndex table, and the email +# ID of the user in question. The Table must have a Username field. +# There is an exception: If the global "$extra" is set to "none", %info will +# be emptied. +# + my $email = $_[1]; + my $link_id = $_[2]; + if (!defined $email or $extra and $extra eq 'none') { + %info = (); + return; + } + if (!$extra or $extra eq 'Users') { + if ($DB->table('Users')->count({ Email => $email })) { + %info = %{$DB->table('Users')->select({ Email => $email })->fetchrow_hashref}; + } + else { + %info = (); + } + } + else { + %info = %{$DB->table('Links', 'Users')->select({ 'Links.ID' => $link_id })->fetchrow_hashref()}; + } +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-image1.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-image1.cgi new file mode 100755 index 0000000..bed47f8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-image1.cgi @@ -0,0 +1,156 @@ +#!/usr/bin/perl5 +# ================================================================== +# Links SQL - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# Revision : $Id: nph-imageresize.cgi,v 1.4 2006/07/31 18:41:26 aki 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. +# ================================================================== + use lib '.'; + + use strict; + use vars qw/$USE_HTML/; + use Links qw/$IN $DB $CFG/; + use Links::Plugins; + use Plugins::SlideShow; + use GT::TempFile; + use GT::SQL::File; + + $| = 1; + Links::init('.'); + + main(); + +sub main { +# -------------------------------------------------- + $USE_HTML = exists $ENV{REQUEST_METHOD} ? 1 : 0; + local $SIG{__DIE__} = \&Links::fatal if $USE_HTML; + + my $links = $DB->table( 'Links' ) or die $GT::SQL::error; + +# Beautify output... + my $lcount = $links->count; + if ( $USE_HTML ) { + print qq~ + + + Resizing images database + + + ~; + print Links::header ('Updating Links ...', 'Links SQL is now attempting to update your $lcount links, please be patient, this can take a while.', 0); + print '
        ';
        +    }
        +    else {
        +        print "\nUpdating $lcount links\n\n";
        +    }
        +
        +# Get the fields we need to check
        +    my $cfg    = Links::Plugins->get_plugin_user_cfg( 'SlideShow' );
        +    my ( $max_width, $max_height, $image_cols,  $temp_dir  ) = 
        +    map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |;
        +
        +# Prepare the required resize parameters
        +    my %con;
        +    foreach my $ind (1..2) {
        +        my @constraints;
        +        foreach ( @Plugins::SlideShow::image_types ) {
        +            my $c = $cfg->{"${_}_constraints_${ind}"} or next;
        +            my ( $crop, $mx, $my ) = $c =~ /(crop)?(\d+)\s*[,x]\s*(\d+)/i;
        +            push @constraints, [ $_, $crop, $mx, $my];
        +        }
        +        $con{$cfg->{"link_type_$ind"}} = \@constraints;
        +    }
        +
        +    my @image_cols = grep { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $image_cols;
        +
        +    my $tmp_dir    = $CFG->{admin_root_path} . "/tmp";
        +# Now do it. This is the really slow part.
        +    $links->select_options( "order by ID" );
        +    my $ID = $IN->param('ID');
        +    my $cond = GT::SQL::Condition->new();
        +    if ($ID) {
        +        $cond->add('ID','=',$ID);
        +    } 
        +    my $link_handle = $links->select([ 'ID', 'Link_Type', @image_cols ], $cond) or die $GT::SQL::error;
        +
        +    my $i = 1;
        +    while ( my $link = $link_handle->fetchrow_hashref ) {
        +        my %new_rec = ();
        +        my @ftemp   = ();
        +
        +        foreach my $c ( @image_cols ) {
        +            next unless $link->{$c};
        +
        +            my $source_path = $links->file_info( $c, $link->{ID} ) or do {
        +                warn "Could not fetch file for link $link->{ID} '$GT::SQL::error'\n";
        +                next;
        +            };
        +
        +my $i = $c;
        +$i =~ s/Image//ig;
        +            my ( $target_image_name ) = $source_path =~ /([\.\w]+)$/;
        +            my $link_type = ($link->{Link_Type}) ? $link->{Link_Type} : 'article';
        +            my $constraints = $con{$link_type};
        +            foreach my $r ( @$constraints ) {
        +                my $target_fpath = "$tmp_dir/$r->[0]_${i}_$target_image_name";
        +                print $target_fpath . "\n";
        +                next unless -f $source_path;
        +                next unless -s $source_path;
        +
        +                if ( $r->[1] ) { # if set to crop
        +                    Plugins::SlideShow::crop_resize_image( 
        +                        $source_path, 
        +                        $target_fpath, 
        +                        $r->[2], # max width
        +                        $r->[3], # max height 
        +                        $cfg->{image_quality}
        +                    );
        +                }
        +                else { # It's a standard resize
        +                    Plugins::SlideShow::resize_image( 
        +                        $source_path, 
        +                        $target_fpath, 
        +                        $r->[2], # max width
        +                        $r->[3], # max height 
        +                        $cfg->{image_quality}
        +                    );
        +                }
        +
        +                if (  $cfg->{watermark_path} and $r->[0] > 100 and $r->[1] > 100 ) {
        +                    apply_watermark( $target_fpath, $cfg->{watermark_path}, $cfg->{image_quality} );
        +                }
        +
        +                push @ftemp, $target_fpath;
        +                $new_rec{"${c}_$r->[0]"} = GT::SQL::File->open( $target_fpath );
        +            }
        +        }
        +
        +        print $link->{ID} . ( keys %new_rec ? "*" : "" ) . " ";
        +        $i++ % 10 or print "\n";
        +
        +        next unless keys %new_rec;
        +
        +        $new_rec{SlideShowCache} = ''; # flush the cache
        +
        +        $links->update( \%new_rec, { ID => $link->{ID} } ) or do {
        +            warn "Could not update link $link->{ID} '$GT::SQL::error'\n";
        +            next;
        +        };
        +    }
        +
        +# End beautiful output
        +    if ($USE_HTML) {
        +        print "\nDone!
        \n\n"; + } + else { + print "\n\nDone!\n" + } +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-imageresize.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-imageresize.cgi new file mode 100755 index 0000000..8cab946 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-imageresize.cgi @@ -0,0 +1,148 @@ +#!/usr/bin/perl5 +# ================================================================== +# Links SQL - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# Revision : $Id: nph-imageresize.cgi,v 1.4 2006/07/31 18:41:26 aki 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. +# ================================================================== + use lib '.'; + + use strict; + use vars qw/$USE_HTML/; + use Links qw/$IN $DB $CFG/; + use Links::Plugins; + use Plugins::SlideShow; + use GT::TempFile; + use GT::SQL::File; + + $| = 1; + Links::init('.'); + + main(); + +sub main { +# -------------------------------------------------- + $USE_HTML = exists $ENV{REQUEST_METHOD} ? 1 : 0; + local $SIG{__DIE__} = \&Links::fatal if $USE_HTML; + + my $links = $DB->table( 'Links' ) or die $GT::SQL::error; + +# Beautify output... + my $lcount = $links->count; + if ( $USE_HTML ) { + print qq~ + + + Resizing images database + + + ~; + print Links::header ('Updating Links ...', 'Links SQL is now attempting to update your $lcount links, please be patient, this can take a while.', 0); + print '
        ';
        +    }
        +    else {
        +        print "\nUpdating $lcount links\n\n";
        +    }
        +
        +# Get the fields we need to check
        +    my $cfg    = Links::Plugins->get_plugin_user_cfg( 'SlideShow' );
        +    my ( $max_width, $max_height, $image_cols,  $temp_dir  ) = 
        +    map { $cfg->{$_} || undef } qw| max_width max_height image_cols temp_dir |;
        +
        +# Prepare the required resize parameters
        +    my %con;
        +    foreach my $ind (1..2) {
        +        my @constraints;
        +        foreach ( @Plugins::SlideShow::image_types ) {
        +            my $c = $cfg->{"${_}_constraints_${ind}"} or next;
        +            my ( $crop, $mx, $my ) = $c =~ /(crop)?(\d+)\s*[,x]\s*(\d+)/i;
        +            push @constraints, [ $_, $crop, $mx, $my];
        +        }
        +        $con{$cfg->{"link_type_$ind"}} = \@constraints;
        +    }
        +
        +    my @image_cols = grep { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $image_cols;
        +
        +    my $tmp_dir    = $CFG->{admin_root_path} . "/tmp";
        +# Now do it. This is the really slow part.
        +    $links->select_options( "order by ID" );
        +    my $link_handle = $links->select([ 'ID', 'Link_Type', @image_cols ]) or die $GT::SQL::error;
        +
        +    my $i = 1;
        +    while ( my $link = $link_handle->fetchrow_hashref ) {
        +        my %new_rec = ();
        +        my @ftemp   = ();
        +
        +        foreach my $c ( @image_cols ) {
        +            next unless $link->{$c};
        +
        +            my $source_path = $links->file_info( $c, $link->{ID} ) or do {
        +                warn "Could not fetch file for link $link->{ID} '$GT::SQL::error'\n";
        +                next;
        +            };
        +
        +            my ( $target_image_name ) = $source_path =~ /([\.\w]+)$/;
        +            my $link_type = ($link->{Link_Type}) ? $link->{Link_Type} : 'article';
        +            my $constraints = $con{$link_type};
        +            foreach my $r ( @$constraints ) {
        +                my $target_fpath = "$tmp_dir/$r->[0]_$target_image_name";
        +                next unless -f $source_path;
        +                next unless -s $source_path;
        +
        +                if ( $r->[1] ) { # if set to crop
        +                    Plugins::SlideShow::crop_resize_image( 
        +                        $source_path, 
        +                        $target_fpath, 
        +                        $r->[2], # max width
        +                        $r->[3], # max height 
        +                        $cfg->{image_quality}
        +                    );
        +                }
        +                else { # It's a standard resize
        +                    Plugins::SlideShow::resize_image( 
        +                        $source_path, 
        +                        $target_fpath, 
        +                        $r->[2], # max width
        +                        $r->[3], # max height 
        +                        $cfg->{image_quality}
        +                    );
        +                }
        +
        +                if (  $cfg->{watermark_path} and $r->[0] > 100 and $r->[1] > 100 ) {
        +                    apply_watermark( $target_fpath, $cfg->{watermark_path}, $cfg->{image_quality} );
        +                }
        +
        +                push @ftemp, $target_fpath;
        +                $new_rec{"${c}_$r->[0]"} = GT::SQL::File->open( $target_fpath );
        +            }
        +        }
        +
        +        print $link->{ID} . ( keys %new_rec ? "*" : "" ) . " ";
        +        $i++ % 10 or print "\n";
        +
        +        next unless keys %new_rec;
        +
        +        $new_rec{SlideShowCache} = ''; # flush the cache
        +
        +        $links->update( \%new_rec, { ID => $link->{ID} } ) or do {
        +            warn "Could not update link $link->{ID} '$GT::SQL::error'\n";
        +            next;
        +        };
        +    }
        +
        +# End beautiful output
        +    if ($USE_HTML) {
        +        print "\nDone!
        \n\n"; + } + else { + print "\n\nDone!\n" + } +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-import.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-import.cgi new file mode 100755 index 0000000..8f0608b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-import.cgi @@ -0,0 +1,235 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: nph-import.cgi,v 1.22 2005/09/19 23:11:16 brewt 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. +# ================================================================== + +use 5.004_04; +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use vars qw/$Int $Error_FH $Critical_Warnings $Show_Mild_Warnings/; +use DBI; +use Links qw/$IN $CFG/; +use GT::SQL; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +main(); + +sub get_rec (\*\%$;\@); + +sub main { +# ----------------------------------------------------------------------------- +# Load either the CGI interface or Text interface, and turn off all buffering. +# + select((select(STDERR),$|=1)[0]),$|=1; + if ($ENV{REQUEST_METHOD}) { + require Links::Import::Interface::CGI; + $Int = new Links::Import::Interface::CGI; + } + else { + require Links::Import::Interface::Text; + $Int = new Links::Import::Interface::Text; + } + $Error_FH = \do { local *FH; *FH }; + +# Get Import options. + my %option = $Int->get_options(); + unless (keys %option) { + return $Int->start_page(); + } + if ($option{help}) { + return $Int->show_help(); + } + if ($option{transfer} eq "S1S2") { # Links SQL 1 to Links SQL 2 + $option{source} or $Int->usage("You must provide the path to the Links SQL 1 def files","--source"); + -d $option{source} or $Int->usage("The path to the Links SQL 1 def files that you gave does not exist", "--source"); + $option{destination} or $Int->usage("You must provide the path to the Links SQL 2 def files","--destination"); + -d $option{destination} or $Int->usage("The path to the Links SQL 2 def files that you gave does not exist", "--destination"); + } + elsif ($option{transfer} eq "L1S2") { # Links 1.x to Links SQL 2 + $option{source} or $Int->usage("You must provide the path to the Links 1.x def and db files","--source"); + -d $option{source} or $Int->usage("The path to the Links 1.x def and db files that you gave does not exist", "--source"); + $option{destination} or $Int->usage("You must provide the path to the Links SQL 2 def files","--destination"); + -d $option{destination} or $Int->usage("The path to the Links SQL 2 def files that you gave does not exist", "--destination"); + } + elsif ($option{transfer} eq "L2S2") { # Links 2.x to Links SQL 2 + $option{source} or $Int->usage("You must provide the path to the Links 2.x def and db files","--source"); + -d $option{source} or $Int->usage("The path to the Links 2.x def and db files that you gave does not exist", "--source"); + $option{destination} or $Int->usage("You must provide the path to the Links SQL 2 def files","--destination"); + -d $option{destination} or $Int->usage("The path to the Links SQL 2 def files that you gave does not exist", "--destination"); + } + elsif ($option{transfer} eq "BKS2") { # Backup File to Links SQL 2 + $option{source} or $Int->usage("You must provide the path and filename of the backup file to restore","--source"); + $option{destination} or $Int->usage("You must provide the path to the Links SQL 2 def files","--destination"); + -d $option{destination} or $Int->usage("The path to the Links SQL 2 def files that you gave does not exist","--destination"); + -f $option{source} or $Int->usage("The backup filename that you gave does not exist","--source"); + $option{clear_tables} or $Int->usage("The 'Clear Tables' option must be enabled when performing a restoration from a backup file", "--clear-tables"); + } + elsif ($option{transfer} eq "S2BK") { # Links SQL 2 to Backup File + $option{source} or $Int->usage("You must provide the path to the Links SQL 2 def files","--source"); + -d $option{source} or $Int->usage("The path to the Links SQL 2 def files that you gave does not exist","--source"); + $option{destination} or $Int->usage("You must provide a destination filename for the backup file","--destination"); + $option{delimiter} = "|"; # Fixed delimiter + } + elsif ($option{transfer} eq "RDFS2" and ref $Int eq "Links::Import::Interface::Text") { # RDF import - can ONLY be done from shell + if (not $option{source}) { + $Int->usage("You must provide the path and filename to the RDF file","--source"); + } + elsif (not -r $option{source}) { + $Int->usage("The path and filename to the RDF file that you gave does not exist, or does not have read permissions set correctly", "--source"); + } + $option{rdf_category} or $Int->usage("You must specify an RDF category to import","--rdf-category"); + if (not $option{rdf_add_date} or $option{rdf_add_date} !~ /^\d{4}-\d\d-\d\d$/) { + $Int->usage("You must specify a valid RDF Add_Date in the format `YYYY-MM-DD'","--rdf-add-date"); + } + } + elsif (!$option{transfer}) { + $Int->usage("You did not specify the import format or backup/restore function","--import, --backup, or --restore"); + $Int->show_usage; + critical("You did not specify the import format or backup/restore function"); + } + else { + $Int->usage("Invalid import format specified","--import"); + $Int->show_usage; + critical("Invalid import format specified"); + } + if ($option{straight_import} and not $option{clear_tables}) { + $Int->usage("the `Straight Import' option can only be used if `Clear Tables' has been turned on","--straight-import --clear-tables"); + $Int->show_usage; + critical("the `Straight Import' option not allowed unless `Clear Tables' has been turned on"); + } + $Int->has_usage() and $Int->show_usage, exit; + if ($option{error_file}) { + if (ref $option{error_file} eq "CODE") { + $Error_FH = $option{error_file}; + } + elsif (uc $option{error_file} eq 'STDOUT') { + open $Error_FH, ">&STDOUT"; + select +(select($Error_FH),$|=1)[0]; + } + elsif (uc $option{error_file} eq 'STDERR') { + open $Error_FH, ">&STDERR"; + select +(select($Error_FH),$|=1)[0]; + } + else { + unless (open $Error_FH,"> $option{error_file}") { + $Int->usage("Invalid error file: Cannot open $option{error_file}: $!"); + $Int->show_usage; + exit; + } + select +(select($Error_FH),$|=1)[0]; + } + } + else { + open $Error_FH, ">&STDERR"; + select +(select($Error_FH),$|=1)[0]; + } + $Critical_Warnings = delete $option{critical_warnings}; + $Show_Mild_Warnings = delete $option{show_mild_warnings}; + +# Switch delims from windows to unix + $option{source} =~ s,\\,/,g; + $option{destination} =~ s,\\,/,g; + + + do_import(%option); + $Int->finished(); +} + +sub mild_warning { +# ----------------------------------------------------------------------------- +# Display mild warnings. +# + if ($Show_Mild_Warnings) { + for (@_) { error("Warning: $_") } + } + 0; +} + +sub warning { +# ----------------------------------------------------------------------------- +# Display warnings. +# + if ($Critical_Warnings) { + goto &critical; + } + else { + for (@_) { error("WARNING: $_") } + } + 0; +} + +sub critical { +# ----------------------------------------------------------------------------- +# Display critical warnings. +# + my ($prog,$line) = (caller(1))[1,2]; + for (@_) { error("CRITICAL ERROR OCCURED: $_ at $prog line $line\n\n") } + print STDERR join('\n',map "CRITICAL ERROR OCCURED: $_", @_)." at $prog line $line\n"; + exit 0xff; # mimics die() +} + +sub error { +# ----------------------------------------------------------------------------- +# Display error messages. +# + local ($,,$\); + if (ref $Error_FH eq "CODE") { + $Error_FH->(@_); + } + else { + local $,="\n"; + local $\="\n"; + if (defined fileno $Error_FH) { + print $Error_FH @_; + } + else { + print @_; + } + } + return; +} + +sub do_import (\%) { +# ----------------------------------------------------------------------------- +# Do the actual import. +# + my $opt = @_ == 1 ? shift : {@_}; + $Int->pre_import(); + if ($$opt{transfer} eq "S1S2") { + require Links::Import::S1S2; + return Links::Import::S1S2::import($opt,\&warning,\&critical,\&mild_warning); + } + elsif ($$opt{transfer} eq "S2BK") { + require Links::Import::S2BK; + return Links::Import::S2BK::import($opt,\&warning,\&critical,\&mild_warning); + } + elsif ($$opt{transfer} eq "BKS2") { + require Links::Import::BKS2; + return Links::Import::BKS2::import($opt,\&warning,\&critical,\&mild_warning); + } + elsif ($$opt{transfer} eq "L1S2") { + require Links::Import::L1S2; + return Links::Import::L1S2::import($opt,\&warning,\&critical,\&mild_warning); + } + elsif ($$opt{transfer} eq "L2S2") { + require Links::Import::L2S2; + return Links::Import::L2S2::import($opt,\&warning,\&critical,\&mild_warning); + } + elsif ($$opt{transfer} eq "RDFS2") { + require Links::Import::RDFS2; + return Links::Import::RDFS2::import($opt,\&warning,\&critical,\&mild_warning); + } +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-index.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-index.cgi new file mode 100755 index 0000000..62e1011 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-index.cgi @@ -0,0 +1,225 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: nph-index.cgi,v 1.38 2006/05/04 02:52:10 brewt 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. +# ================================================================== + +# Load Time::HiRes if available for better time checking. +# Must appear here, or we get strange errors. +BEGIN { eval { require Time::HiRes; import Time::HiRes qw/time/; }; } + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +main(); + +sub main { +# ------------------------------------------------------------------- +# Reindexes the entire database. +# + if (! $ENV{REQUEST_METHOD} ) { + if (! @ARGV) { + return usage(); + } + else { + if ($ARGV[0] =~ /change-driver=(\w+)/) { + $PLG->dispatch('change_driver', \&change_driver, "$1"); + } + elsif ($ARGV[0] =~ /reindex/) { + $PLG->dispatch('reindex_database', \&reindex); + } + else { + print "Invalid Argument: @ARGV\n"; + return usage(); + } + } + } + else { + $PLG->dispatch('reindex_database', \&reindex); + } +} + +sub usage { +# ------------------------------------------------------------------ +# Print a usage summary. +# + require GT::SQL::Search; + my $drivers = join ",", GT::SQL::Search->available_drivers; + print <header ( -nph => $CFG->{nph_headers} ); + print qq~ + + +Reindexing Database + + + +
        + + + + + + + +
        Reindexing Database ...
        +

        Reindexing Database ...

        +

        Gossamer Links is now going to re-index your database, please be patient, this can take a while. Please note: this is only neccessary if you have manually changed the database outside of Gossamer Links. +

        +
        + ~; + print qq~ +
        Started at $t.
        +
        +Indexing Links Database ... ~;
        +    }
        +    else {
        +        print "Started at $t.\n\nReindexing Gossamer Links Database ... ";
        +    }
        +
        +# Get our Links db object.
        +    $links = $DB->table('Links');
        +    if ($links->{schema}->{search_driver} ne 'NONINDEXED') {
        +        $total = $links->count(VIEWABLE) || 0;
        +        $weights = $links->weight || {};
        +        $found = 0;
        +        foreach (keys %$weights) {
        +            $weights->{$_} > 0 and ($found = 1);
        +        }
        +        if (! $found) {
        +            if ($use_html) {
        +                print "No search weights have been defined, skipping!\n";
        +            }
        +            else {
        +                print "No search weights have been defined, skipping!\n\n";
        +            }
        +        }
        +        else {
        +            print "$total links.\n";
        +            $links->reindex( { tick => 1000, max => 10000, cond => VIEWABLE } );
        +            print "\nDone!\n\n";
        +        }
        +    }
        +    else {
        +        if ($use_html) {
        +            print "Links table is using the NONINDEXED indexing scheme, skipping!\n";
        +        }
        +        else {
        +            print "Links table is using the NONINDEXED indexing scheme, skipping!\n\n";
        +        }
        +    }
        +
        +    print "Reindexing Category Database ... ";
        +    $category = $DB->table('Category');
        +    if ($category->{schema}->{search_driver} ne 'NONINDEXED') {
        +        $total = $category->count  || 0;
        +        $weights = $category->weight || {};
        +        $found = 0;
        +        foreach (keys %$weights) {
        +            $weights->{$_} > 0 and ($found = 1);
        +        }
        +        if (! $found) {
        +            if ($use_html) {
        +                print "No search weights have been defined, skipping!\n";
        +            }
        +            else {
        +                print "No search weights have been defined, skipping!\n\n";
        +            }
        +        }
        +        else {
        +            print "$total categories.\n";
        +            $category->reindex( { tick => 1000, max => 10000 } );
        +
        +            print "\nDone!\n\n";
        +        }
        +    }
        +    else {
        +        if ($use_html) {
        +            print "Category table is using the NONINDEXED indexing scheme, skipping!\n";
        +        }
        +        else {
        +            print "Category table is using the NONINDEXED indexing scheme, skipping!\n\n";
        +        }
        +    }
        +
        +# All done.
        +    $f = time();
        +    $e = $f - $s;
        +    printf ("All Done (%.2f s)\n\n", $e);
        +    if ($use_html) {
        +        print "
        "; + } +} + +sub change_driver { +# ------------------------------------------------------------------- + my $new_driver = shift or die "Please supply a drivername to change to"; + + my $err = ''; + my $eLinks = $DB->editor('Links'); + my $eCats = $DB->editor('Category'); + + print "Please be warned that this action may take an extended period of time to complete\n\n"; + print "Updating Links Table search driver...\n"; + print " "x5, $eLinks->change_search_driver( $new_driver ) ? "Completed\n" : ( $err = "Error: $GT::SQL::error\n" ); + + print "\nUpdating Category Table search driver...\n"; + print " "x5, $eCats->change_search_driver( $new_driver ) ? "Completed\n" : ( $err ="Error: $GT::SQL::error\n" ); + + if ($err) { + print "\nThere were problems switching drivers.\n\n"; + } + else { + print "\nThe drivers have now been switched. Please be sure to reindex the tables.\n\n"; + } +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-verify.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-verify.cgi new file mode 100755 index 0000000..9f4bcc5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-verify.cgi @@ -0,0 +1,470 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: nph-verify.cgi,v 1.45 2006/12/27 17:02:34 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use vars qw/$USE_HTML $TODAY $GOOD $BAD @CACHE $MAX_ID/; +use Links qw/$IN $DB $CFG/; + +$USE_HTML = exists $ENV{REQUEST_METHOD} ? 1 : 0; + +$TODAY = get_date(); + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + + +main(); + +sub main { +# ------------------------------------------------------------------- + +# get the option parameters + my $params = 0; + my $id = 0; + my ($method); + if ($USE_HTML) { + +# If there is a command line argument while in USE_HTML mode that means that +# this is a child. + if (@ARGV == 2 or $ENV{verifier_lock_fpath}) { + my $lock_fpath = $ENV{verifier_lock_fpath} + || $ARGV[1]; # want the second parameter as the first should be --child + delete $SIG{__DIE__}; + child($lock_fpath); + return; + } + +# Otherwise, this is the parent + print $IN->header(-nph => $CFG->{nph_headers}); + $_ = $IN->param("do"); + } + else { + $_ = join " ", @ARGV; +# convert command line params to parseable commands + if (/--check[_-]all/) { ($_, $method) = ("check_links", 5) } + elsif (/--check[_-]from\s+(\d+)/) { ($_, $method, $params) = ("check_links", 1, $1) } + elsif (/--check[_-]new/) { ($_, $method) = ("check_links", 4) } + elsif (/--check[_-]problem/) { ($_, $method) = ("check_links", 3) } + elsif (/--check[_-]status\s+(-?\d+)/) { ($_, $method, $params) = ("check_links", 6, $1) } + elsif (/--check\s*(-?\d+)/) { ($_, $method, $id) = ("check_links", 7, $1) } + elsif (/--fix[_-]302/) { $_ = "fix_302" } + elsif (/--child\s*(.+)/) { child($1); return } # $1 should contain lock fpath + else { $_ = undef } + } + +# If no input just display the information screen + if (not defined) { + return $USE_HTML ? Links::admin_page('tools_verify.html') : command_line_help(); + } + + $CFG->{verify_max_children} = $IN->param('verify_max_children') || $CFG->{verify_max_children} || 3; + $CFG->{verify_chunk} = $IN->param('verify_chunk') || $CFG->{verify_chunk} || 10; + $CFG->save; + +# Otherwise, try to fulfill the request + if ($USE_HTML) { + if (defined $IN->param("method")) { + check_links( + scalar $IN->param("method") || 5, + scalar $IN->param("status") || 0, + scalar $IN->param("ID") || 0, + scalar $IN->param("days") || 0, + scalar $IN->param("since"), + scalar $IN->param("to") + ); + } + else { + return Links::admin_page('tools_verify.html'); + } + } + else { + check_links($method, $params, $id, $params); + } + +} + +sub command_line_help { +# ------------------------------------------------------------------- +# Print out a usage summary. +# + print <<'HELP'; +This script checks the Gossamer Links database for link integrity. + +The following parameters may be used from the command line: + +For checking links: (one of) + --check-from number_of_days_ago + --check-problem + --check-new + --check-status status_code + --check-all + +For fixing links: + --fix-302 + +HELP +}; + +sub child { +# ------------------------------------------------------------------- + my $temp_fpath = shift; + + require Symbol; + my $fh = Symbol->gensym; + my $counter = 1; + my $entry_size = 4; + + require Links::Tools; + + while (1) { + while (-f "$temp_fpath.wait") { + if ($counter++ == 50) { + open $fh, "<$temp_fpath.wait" or warn "While trying to read '$temp_fpath.wait' got error: '$!'"; + my $pid = int <$fh>; + close $fh; + + if (kill 0, $pid) { + warn "$pid has locked id file for long time. Will continue testing for another 50 interations then give up."; + } + else { + warn "$pid has locked id file but it seems to have abnormally terminated. Removing .wait file and proceeding."; + unlink "$temp_fpath.wait"; + } + } + elsif ($counter > 100) { + warn "$$ stopping run since pid file is locked for too long."; + return; + } + select undef, undef, undef, 0.5; + } + + my $old_sig = $SIG{INT}; + $SIG{INT} = sub { + unlink "$temp_fpath.wait"; + if ($old_sig) { + goto &$old_sig; + } + else { + exit; + } + }; + + open $fh, "> $temp_fpath.wait"; + print $fh $$; + close $fh; + + my $index = 0; + if (-f "$temp_fpath.ndx") { + open $fh, "< $temp_fpath.ndx"; + $index = int <$fh>; + close $fh; + } + +# offset into proper location in the file and get all the entries that need +# testing + my $file_index = $index * $entry_size; + + if ($file_index > -s $temp_fpath) { + unlink "$temp_fpath.wait"; + exit; + } + + my $entry_buf = ''; + + open $fh, "< $temp_fpath"; + sysseek $fh, $file_index, 0; + sysread $fh, $entry_buf, $entry_size * $CFG->{verify_chunk}; + close $fh; + +# now we can write the new index into the .ndx file for subsequence child +# requests + open $fh, "> $temp_fpath.ndx"; + $index += $CFG->{verify_chunk}; + print $fh $index; + close $fh; + +# finally all actions have been completed here so we can release our lock on +# the data file and let other children access the index + unlink "$temp_fpath.wait"; + $SIG{INT} = $old_sig || ''; + +# Need to convert all the ids that we fetched into usable workunits + my @work_unit = unpack "l*", $entry_buf; + +# exit when there are no more work units + unless (@work_unit) { + warn "Child Done!"; + return; + } + + my $results = Links::Tools::check_links(@work_unit); + commit_results($results); + } +} + +sub check_links { +#---------------------------------------------------------------------- +# generates the sql query that nabs the link subset that we want +# to check then checks the links +# + my ($action, $status, $id, $days, $since, $to) = @_; + +# make sure everything is what we expect it to be + $status = int $status; + $id = int $id; + $days = int $days; + $since ||= ''; + $since =~ m|(\d{4}/\d\d?/\d\d?)|; + $since = $1; + $to ||= ''; + $to =~ m|(\d{4}/\d\d?/\d\d?)|; + $to = $1; + +# build the query condition. + require GT::SQL::Condition; + my $cond = new GT::SQL::Condition; + if ($action == 1) { + # not checked in the last N days + my $tmp_date = get_date(time - (86400 * $days)); + $cond->add("Date_Checked", "<", $tmp_date); + } + elsif ($action == 2) { + # checked last between N and O + $cond->add("Date_Checked", ">", $since); + $cond->add("Date_Checked", "<", $to); + } + elsif ($action == 3) { + # problem links + require Links::Tools; + $cond->add(Status => [keys %Links::Tools::STATUS_BAD]); + } + elsif ($action == 4) { + # new links + $cond->add("Status", "=", 0); + } + elsif ($action == 5) { + # everything + $cond = {}; + } + elsif ($action == 6) { + # check something based on status code + $cond->add("Status", "=", $status); + } + elsif ($action == 7) { + # check a certain link + $cond->add("ID", "=", $id); + } + +# find out how many items need to be checked..., + my $link_db = $DB->table('Links'); + my $count = $link_db->count($cond) || 0; + + if ($USE_HTML) { + print <<' HTML'; + + +Checking Links + + HTML + print Links::header('Checking Links ...', 'Gossamer Links is now attempting to check your links, please be patient, this can take a while.', 0); + print '
        ';
        +    }
        +    else {
        +        print "Checking $count links...\n\n";
        +    }
        +
        +    my $start_time = time;
        +
        +    unless ($count) {
        +        print "No links to check!\n\n";
        +    }
        +    else {
        +
        +# Get all the links we're going to check.
        +# Done here so that we get the results before we call GT::TempFile to avoid any
        +# concurrency issues.
        +        my $link_sth = $DB->table('Links')->select(ID => $cond);
        +
        +# Figure out where our new tempfile will live.
        +        require GT::TempFile;
        +        require Symbol;
        +        my $temp_file = GT::TempFile->new(destroy => 0);
        +        my $temp_fpath = $$temp_file;
        +
        +# First, fetch all the links to be checked and place them into a temp file for
        +# fast retrieval by children.
        +        my $temp_fh = Symbol::gensym();
        +        my $entry_size = 4; # need this for lookups
        +        open $temp_fh, "> $temp_fpath";
        +        while (my $id = $link_sth->fetchrow) {
        +            print $temp_fh pack("l", $id);
        +        }
        +        close $temp_fh;
        +
        +# Now, we can launch all the children that will start grabbing links
        +
        +        require Links::Tools;
        +        require GT::IPC::Run;
        +        require GT::IPC::Filter::Line;
        +
        +# Get links for the child to work upon. This functions by making sure the .wait
        +# file is not available or at least random time based checks until it is.  when
        +# it does finish, it will update the ndx file, which contains that index up to
        +# the last item that was accessed then remove the .wait file it had just
        +# created and continue with the checking of the fetched records.  Once the
        +# .wait file has been removed, other concurrently running children can then
        +# access the ndx
        +#
        +# We launch a new process instead of forking because...
        +#
        +#   Verifier seems to lock up after a failure that throws debug output.
        +#       Problematic especially under mod_perl
        +#   ODBC DBI handles are not shareable between threads without a clone.
        +#
        +# Ideally, the following line could have been used:
        +# $child_function = sub { child( $temp_fpath ) };
        +#
        +        my $child_function = "$CFG->{path_to_perl} $CFG->{admin_root_path}/nph-verify.cgi  --child $temp_fpath";
        +
        +        my $line_function = sub {
        +        # --------------------------------------------------
        +            my $line = shift;
        +            my %values;
        +            my ($id, $status, $url) = split /\t/, $line;
        +
        +            return unless $id and $status;
        +            $url ||= 'Missing URL';
        +
        +            $USE_HTML ?
        +                print qq|Checked $id - $url - | :
        +                print "$id\t$url\t";
        +
        +            if ($Links::Tools::STATUS_OK{$status}) {
        +                $GOOD++;
        +                print "Success ($status). Message: $Links::Tools::STATUS_OK{$status}";
        +            }
        +            else {
        +                $BAD++;
        +                print "Request Failed (" . ($status || "unresolvable") . ")";
        +                if ($status and $Links::Tools::STATUS_BAD{$status}) {
        +                    print " Message: $Links::Tools::STATUS_BAD{$status}";
        +                }
        +            }
        +
        +            print "\n";
        +        };
        +
        +        my $ofilter = GT::IPC::Filter::Line->new($line_function);
        +
        +# Do the part that launches all the children.
        +        my $ipc = GT::IPC::Run->new;
        +
        +        for (1 .. $CFG->{verify_max_children}) {
        +            $ipc->start(
        +                stdout  => $ofilter,
        +                program => $child_function
        +            ) or die $ipc->error;
        +            print scalar(localtime) . " New child started\n";
        +        }
        +
        +        print "Finished launching children\n";
        +
        +# Setup a signal handler on INT just in case we get an abnormal stop.
        +        local $SIG{INT} = sub {
        +            print "Unlinking temp files.\n";
        +            unlink $temp_fpath;
        +            unlink "$temp_fpath.wait";
        +            unlink "$temp_fpath.ndx";
        +            display_stats($start_time);
        +            exit;
        +        };
        +
        +# Iterate until all the children have finished processing.
        +        $ipc->do_loop;
        +    }
        +
        +    display_stats($start_time);
        +
        +}
        +
        +sub display_stats {
        +# --------------------------------------------------
        +# And can now print stats on how the checking went
        +# Triggered by an INT signal or on normal termination
        +# of the script.
        +#
        +    my $start_time = shift;
        +    my $end_time = time;
        +    my $run_time = $end_time - $start_time;
        +
        +    {
        +        last unless $run_time;
        +
        +        print "\n\n";
        +        print "Total Run Time: $run_time second(s)\n";
        +
        +        $GOOD ||= 0;
        +        $BAD  ||= 0;
        +        my $total_links = $GOOD + $BAD or last;
        +
        +        print "Total Links checked: $total_links\n";
        +
        +        print "Total Links Bad: $BAD\n";
        +        print "Total Links Good: $GOOD\n\n";
        +        printf "Average time to check one link: %0.2fs\n", $run_time/$total_links;
        +        printf "Average links checked in a second: %0.2f\n", $total_links/$run_time;
        +    }
        +
        +    print "
        \n\n" if $USE_HTML; +} + +sub commit_results { +# -------------------------------------------------- +# Used by a child. This takes a hashref keyed by LinkID +# mapping to HTTP status and stores the results into +# the local database +# + my $results = shift or return; + + my $link_db = $DB->table('Links'); + my $ver_db = $DB->table('Verify'); + + for my $id (keys %$results) { + my $status = $results->{$id}; + next unless $status; + my $t = localtime; + + $ver_db->add({ + LinkID => $id, + Status => $status, + Date_Checked => $TODAY + }) or warn "nph-verify.cgi: error adding to Verify table ($id): $GT::SQL::error"; + + $link_db->update({ Status => $status, Date_Checked => $TODAY }, { ID => $id }) or + warn "nph-verify.cgi: error updating status ($id): $GT::SQL::error"; + } +} + +sub get_date { +# -------------------------------------------------------- +# Private method to translate a unix time value into a date. +# + my $time = shift || time; + $time = time if $time =~ /\D/; + my ($sec, $min, $hour, $day, $mon, $year) = localtime $time; + return sprintf "%04d-%02d-%02d", $year + 1900, $mon + 1, $day; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/nph-videoconvert.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/nph-videoconvert.cgi new file mode 100755 index 0000000..70693b5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/nph-videoconvert.cgi @@ -0,0 +1,90 @@ +#!/usr/local/bin/perl +# ================================================================== +# Links SQL - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# Revision : $Id: nph-imageresize.cgi,v 1.2 2004/12/09 00:55:04 aki 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. +# ================================================================== + use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; + + use strict; + use vars qw/$USE_HTML/; + use Links qw/$IN $DB $CFG/; + use Links::Plugins; + use Plugins::ConvertVideo; + use GT::TempFile; + use GT::SQL::File; + + $| = 1; + Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + + main(); + +sub main { +# -------------------------------------------------- + $USE_HTML = exists $ENV{REQUEST_METHOD} ? 1 : 0; + local $SIG{__DIE__} = \&Links::fatal if $USE_HTML; + + my $links = $DB->table( 'Links' ) or die $GT::SQL::error; + +# Beautify output... + my $lcount = $links->count; + if ( $USE_HTML ) { + print qq~ + + + Converting video database + + + ~; + print Links::header ('Updating Links ...', 'Links SQL is now attempting to update your $lcount links, please be patient, this can take a while.', 0); + print '
        ';
        +    }
        +    else {
        +        print "\nUpdating $lcount links\n\n";
        +    }
        +
        +    my $cfg = Links::Plugins::get_plugin_user_cfg('ConvertVideo');
        +    my $vf_field = $cfg->{video_file_field};
        +    my $ff_field = $cfg->{flash_file_field};
        +    my $thumb  = $cfg->{thumbnail_file_field};
        +
        +# Now do it. This is the really slow part.
        +    $links->select_options( "order by ID" );
        +    my $link_handle = $links->select([ 'ID', $vf_field ], { Link_Type => 'video' } ) or die $GT::SQL::error;
        +
        +    my $i = 1;
        +    while ( my $link = $link_handle->fetchrow_hashref ) {
        +        my $source_path = $links->file_info( $vf_field, $link->{ID} ) or do {
        +            warn "Could not fetch file for link $link->{ID} '$GT::SQL::error'\n";
        +            next;
        +        };
        +        Plugins::ConvertVideo::convert_video($link);
        +
        +        print $link->{ID} . ( $link->{$ff_field} ? "*" : "" ) . " ";
        +        $i++ % 10 or print "\n";
        +        my $id = $link->{ID};
        +        delete $link->{ID};
        +
        +        $links->update( $link, { ID => $id } ) or do {
        +            warn "Could not update link $link->{ID} '$GT::SQL::error'\n";
        +            next;
        +        };
        +    }
        +
        +# End beautiful output
        +    if ($USE_HTML) {
        +        print "\nDone!
        \n\n"; + } + else { + print "\n\nDone!\n" + } +} + +1; + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/oldpages.db b/site/slowtwitch.com/cgi-bin/articles/admin/oldpages.db new file mode 100644 index 0000000..219b4f7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/oldpages.db @@ -0,0 +1,476 @@ +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/A_bike_fitting_first_Angular_head_pin_on_an_X/Y_fit_bike_389.html: Thu Nov 20 00:04:43 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Armrest_drop_25.html: Thu Nov 20 00:03:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Bikes_for_the_torso-impaired_98.html: Thu Nov 20 00:03:26 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Choosing_a_Tri_Bike_via_Stack_and_Reach/Bikes_for_the_torso-impaired_98.html: Tue Dec 30 06:50:33 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Choosing_a_Tri_Bike_via_Stack_and_Reach/Finding_the_right_bike_from_the_bars_back_290.html: Tue Nov 25 07:12:19 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Cockpit_length_22.html: Thu Nov 20 00:03:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Devising_a_static_tri-fit_system_890.html: Wed Jan 20 00:03:47 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/F.I.S.T._Axioms_18.html: Thu Nov 20 00:03:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/F.I.S.T._Protocol_19.html: Thu Nov 20 00:03:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/F.I.S.T._Workshops/F.IS.T._Workshops_47.html: Wed Aug 12 07:18:34 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/F.IS.T._Workshops_47.html: Thu Nov 20 00:03:14 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Finding_the_right_bike_from_the_bars_back_290.html: Thu Nov 20 00:04:14 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Fudging_for_negative_reach_123.html: Thu Nov 20 00:03:31 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Hip_angle_24.html: Thu Nov 20 00:03:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Long_and_low_short_and_narrow_613.html: Thu Nov 20 00:05:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Measuring_conventions_20.html: Thu Nov 20 00:03:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Positional_problems_436.html: Thu Nov 20 00:04:56 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Seat_height_21.html: Thu Nov 20 00:03:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Slowtwitch_debuts_Geometry_Calculator_406.html: Thu Nov 20 00:04:47 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Stack_Reach_Primer_Chapter_One_95.html: Thu Nov 20 00:03:25 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Stack_Reach_Primer_Chapter_Three_97.html: Thu Nov 20 00:03:25 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Stack_Reach_Primer_Chapter_Two_96.html: Thu Nov 20 00:03:25 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/The_F.I.S.T._Method_for_fitting_triathletes_to_their_bikes_16.html: Thu Nov 20 00:03:08 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Tools_of_the_trade_26.html: Thu Nov 20 00:03:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Translating_fit_specs_to_bike_specs_28.html: Thu Nov 20 00:03:11 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Bike_Fit/Your_bike_s_waistline_27.html: Thu Nov 20 00:03:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Armrest_drop_25.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Cockpit_length_22.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/F.I.S.T._Axioms_18.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/F.I.S.T._Protocol_19.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Hip_angle_24.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Measuring_conventions_20.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Seat_height_21.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/The_F.I.S.T._Method_for_fitting_triathletes_to_their_bikes_16.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Tools_of_the_trade_26.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Translating_fit_specs_to_bike_specs_28.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Bike_Fit/Your_bike_s_waistline_27.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Features/Mark_Sisson_says_training_is_no_guarantee_of_health._4.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Features/Skip_Gilbert_interview_3.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Athletes/Benny_Vansteelant_dies_at_age_30_29.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Events/One_more_70.3_event_for_the_USA_14.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/2007_BG_Triathlon_World_Cup_Beijing_preview_23.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Bennett_and_Snowsill_win_2007_LA_Triathlon_10.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Fernandes_finally_does_it_5.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Fernandes_on_fire_in_Beijing_30.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Gomez_dominant_in_Beijing_31.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Lebrun_and_Dibens_win_2007_XTERRA_UK_32.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Perez_and_Louison_take_charge_in_Monaco_12.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Plata_and_Lavelle_take_care_of_business_at_Pacific_Grove_11.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Twelsiek_and_Ferguson_fly_at_Ironman_Wisconsin_2007_7.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Unger_stuns_the_triathlon_world_6.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/News/Races/Wasle_and_Batelier_victorious_at_XTERRA_Germany_2007_13.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Products/2008_USE_Tula_aero_bars_9.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Products/2008_ZG_Negative_G_brakes_17.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Detailed/Training/Aerobic_points_system_15.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/F.I.S.T./F.IS.T._Workshops_47.html: Sat Mar 15 10:28:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/F.I.S.T./Xantusia_46.html: Sat Mar 15 10:28:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/2008_Ironman_70.3_World_Championship_at_Clearwater_Odds_--_the_women_602.html: Fri Nov 7 07:30:51 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/2008_Ironman_70.3_World_Championship_odds_-_The_men_597.html: Fri Nov 7 07:30:51 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Best_of_2010_Galleries_Portraits_1854.html: Mon Jan 10 08:26:52 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Enhanced_Race_Results_Ironman_70.3_Clearwater_and_Ironman_Arizona_2010__1809.html: Mon Dec 6 00:10:09 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Enhanced_Race_Results_Ironman_Hawaii_and_Ironman_Florida_2010__1793.html: Mon Dec 6 00:10:04 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Enhanced_Race_Results_Ironman_Wisconsin_1552.html: Mon Dec 6 00:08:53 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Enhanced_Race_Results_Requests_Filled_1569.html: Mon Dec 6 00:08:59 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Enhanced_Race_Results_Taking_Requests_1557.html: Mon Dec 6 00:08:55 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/In_L.A._USAT_gets_what_it_needs_345.html: Wed May 7 09:49:58 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Inside_the_classic_Hy-Vee_men_s_sprint_finish_896.html: Thu Jul 2 14:18:48 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Island_To_Island_-_The_toughest_one-day-race_in_Sweden__524.html: Thu Sep 18 13:12:56 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Let_us_now_praise_Sheila_Taormina_-_Olympic_Gold_Medalist_swimmer_ITU_World_Champion_Olympic_Moder_486.html: Sat Aug 23 15:54:13 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Let_us_now_praise_Sheila_Taormina__486.html: Sat Aug 23 16:04:54 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Slowtwitch.com_live_from_Beijing_day_2_475.html: Sun Aug 17 06:59:58 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Stayin_Alive_1353.html: Mon Jun 7 09:17:53 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/The_Duel_869.html: Thu Jun 18 12:24:19 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/The_Paradox_of_Politics_and_Purity_of_Purpose__477.html: Sun Aug 17 15:42:47 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/The_first_man_to_break_the_Ironman_3-hour_run_barrier_759.html: Tue Apr 14 00:08:59 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/The_first_to_run_sub-3_in_Kona_759.html: Tue Apr 14 12:22:46 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Thinkers_Tinkers_Robert_Kunz_of_7Systems_1208.html: Wed Feb 10 00:05:41 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tim_Carlson_sets_Olympic_Odds_480.html: Mon Aug 18 16:14:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_11_834.html: Fri May 29 00:10:36 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_12_835.html: Fri May 29 10:41:52 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_14_842.html: Mon Jun 1 00:10:40 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_4_820.html: Fri May 22 00:10:23 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_8_827.html: Mon May 25 18:19:07 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_8_828.html: Mon May 25 18:19:07 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/Tour_of_Sweden_Day_9_830.html: Wed May 27 00:10:43 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/asdfasdfasdf_1493.html: Tue Aug 17 00:06:50 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Features/test_article_491.html: Tue Aug 26 00:02:56 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Forum/admin/templates/admin/markup_tags_modify_2.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Forum/admin/templates/admin/markup_text_modify_2.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/A_Saul_Raisin_update_667.html: Wed Jan 21 00:06:36 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/A_conversation_with_Kiwi_Keegan_Williams_1753.html: Mon Oct 18 15:00:10 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Bozzone_and_Zeiger_rule_Vineman_441.html: Tue Jul 22 10:03:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Charlotte_Paul_From_McDonald_s_to_Ironman_Champion_154.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Get_to_meet_Bjorn_Andersson_286.html: Mon Mar 17 14:59:43 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Gina_Crawford_s_rollercoaster_1142.html: Sun Dec 13 13:55:31 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Gordo_Byrn_shares_his_thoughts_169.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Hook-em_Michael_Klueh_327.html: Mon Apr 21 06:04:33 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Julie_Dibens_interview_Part_2_1249.html: Wed Mar 10 21:28:06 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Los_Angeles_Tri_Club_148.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Macca_-_as_he_sees_is_2070.html: Mon May 16 08:23:09 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Macca_talks_to_Slowtwitch_534.html: Sun Sep 21 15:41:02 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Meet_Uwe_Widmann_472.html: Sat Aug 16 11:57:36 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Paula_Newby-Fraser_reflects_--_Part_2__1234.html: Fri Feb 26 16:26:54 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Q_A_with_3-time_Life_Time_Fitness_Series_champion_Greg_Bennett_619.html: Tue Dec 2 10:07:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Q_A_with_Rebecca_Wassner_779.html: Wed Apr 29 00:09:37 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Q_amp_A_with_3-time_Life_Time_Fitness_Series_champion_Greg_Bennett_619.html: Tue Dec 2 14:15:33 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Running_for_food_-_Maximilian_Longr_e_528.html: Wed Sep 17 16:56:18 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Saul_Raisin_raising_hope_244.html: Sat Mar 15 10:28:43 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/The_tenatious_Scott_Rigsby_655.html: Thu Jan 8 16:18:23 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/The_triathlete_hears_a_different_drummer_1971.html: Wed Mar 30 00:09:49 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Timo_Bracht_is_ready__1064.html: Thu Oct 8 00:05:12 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Interview/Zeiger_sidelined_by_recurring_dizziness_960.html: Tue Aug 11 14:13:08 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Lifestyle/Jenny_Gowan_s_Norseman_report_471.html: Sat Aug 16 00:03:05 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Lifestyle/Looking_For_The_Forum_38.html: Sat Mar 15 10:28:40 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Lifestyle/Xantusia_46.html: Sat Jan 10 08:31:57 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/A_2010_XTERRA_Maui_gallery_1764.html: Sun Oct 24 20:12:06 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Act_Two_From_Chrissie_Who_to_the_Triathlete_from_Another_Planet_577.html: Wed Oct 15 12:48:56 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Alexander_and_Tisseyre_win_Boise_70.3_856.html: Sun Jun 14 12:31:28 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Amber_Monforte_breaks_Ultraman_records__949.html: Mon Aug 10 08:30:02 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/A_chat_with_Alex_Mroszczyk-McDonald_117.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/Benny_Vansteelant_dies_at_age_30_29.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/Bjorn_Anderson_to_race_on_Quintana_Roo_51.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/Floyd_Landis_test_upheld_in_arbitration_41.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/Ghost_runner_go_86.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/Medal_winner_at_age_group_Worlds_admits_cheating_48.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/The_bikes_of_the_top_ten_pro_women_in_Kona_90.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Athletes/The_top_ten_pro_men_in_Kona_and_their_bikes_89.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Atkinson_Ide_win_Ishigaki_World_Cup_777.html: Sun Apr 26 12:10:12 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bauer_and_Mutscheller_win_2008_Winter_Triathlon_World_Cup_opener_179.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bell_and_Wellington_in_Kansas_858.html: Mon Jun 15 11:03:49 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bennett_Wassner_take_New_York_932.html: Sun Jul 26 18:00:53 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bennetts_rule_Augusta_70.3__1042.html: Sun Sep 27 14:39:10 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bozzone_McGlone_take_Galveston_70.3_1317.html: Sun Apr 25 11:44:22 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bozzone_and_Zeiger_on_top_in_Clearwater_604.html: Sat Nov 8 11:40:00 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Bracht_hangs_tough_to_take_Arizona_1803.html: Sun Nov 21 14:54:41 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Brownlee_stuns_field_at_Madrid_WCS_840.html: Sun May 31 10:37:59 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Chrissie_and_Kona_4.0__1575.html: Fri Oct 8 00:07:21 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Collins_Hoogland_win_San_Francisco_Tri_at_Alcatraz_1504.html: Sun Aug 29 15:29:39 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Colting_Biscay_lead_Ultraman_Day_1_1813.html: Sat Nov 27 04:41:49 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Courtney_Atkinson_tops_Kris_Gemmell_at_Mooloolaba_World_Cup_738.html: Sun Mar 29 08:39:06 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Crowie_plays_it_cool_1071.html: Mon Oct 12 00:04:58 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/De_Villiers_and_Rabi_grab_South_African_titles_205.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Desiree_Ficker_10th_at_NYC_Marathon_1099.html: Sun Nov 1 14:27:12 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Did_Silver_medalist_confess_to_EPO__689.html: Tue Feb 10 09:48:06 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Docherty_Tanner_win_NZ_Triathlon_Nationals_723.html: Wed Mar 18 12:54:53 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Docherty_Tanner_win_New_Zealand_Triathlon_Nationals_723.html: Sun Mar 15 14:14:04 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Eagleman_70.3_to_Bozzone_Carfrae_857.html: Sun Jun 14 09:39:36 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Eneko_Llanos_has_a_quiet_chance__1577.html: Fri Oct 8 00:07:22 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Fuji_s_parent_buys_Kestrel_50.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Ironman_Hawaii_airs_on_Saturday_138.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Ironman_wary_of_speedskins_place_pros_on_notice_63.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Jordan_Rapp_first_to_successfully_navigate_the_Soma_99.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Kona_2007_bike_count_77.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/No_more_Ironman_70.3_Baja_36.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/One_more_70.3_event_for_the_USA_14.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Power_Camp_in_Taupo_New_Zealand_121.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Stoltz_and_Dibens_take_2007_Maui_XTERRA_Champs_103.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Events/Trifest_2008_135.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Flying_Argentinian_Eduardo_Sturla__437.html: Tue Jul 22 10:03:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Flying_Kiwi_-_Terenzo_Bozzone__407.html: Tue Jul 22 10:03:38 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Frodeno_sprints_to_Olympic_Gold_481.html: Tue Aug 19 09:45:51 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Frodeno_surprisingly_takes_Olympic_Gold_481.html: Tue Aug 19 04:29:29 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Gemmell_Marsh_in_Singapore_1952.html: Sat Mar 19 22:56:53 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Gemmell_Marsh_win_Singapore_IM_70.3_1952.html: Sat Mar 19 22:01:55 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Gold_for_Snowsill_in_Beijing_478.html: Fri Aug 22 00:02:49 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Gomez_Swallaw_take_La_Baule_1541.html: Sat Sep 18 16:18:52 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Gomez_wins_in_Spain_368.html: Mon May 26 11:07:43 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Griffin_and_Carfrae_capture_Snap_Ironman_70.3_Geelong_197.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/H_tthaler_comes_clean_736.html: Sun Mar 29 11:59:34 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Henning_Paul_sweat_to_wins_at_red-hot_Ironman_China_765.html: Sun Apr 19 05:20:55 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Henning_Paul_win_red-hot_Ironman_China_765.html: Mon Apr 20 07:51:19 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Henning_and_Snowsill_cash_in_a_Hy-Vee_Kemper_and_Haskings_nab_Olympic_spots_403.html: Sun Jun 22 16:52:24 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Henning_and_Snowsill_cash_in_at_Hy-Vee_Kemper_and_Haskings_nab_Olympic_spots_403.html: Mon Jun 23 08:41:27 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Hewitt_out_sprints_Norden_at_Madrid_WCS_839.html: Sun May 31 10:37:59 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Hungarians_sweep_Ironman_Arizona_319.html: Mon Apr 14 10:34:31 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/ITU_WCS_Yokohama_canceled_2018.html: Mon Apr 18 20:30:53 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/ITU_World_Championship_Series_preview_1008.html: Thu Sep 10 16:49:02 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Ironman_glutton_Hilary_Biscay_gets_her_first_win_at_Wisconsin_512.html: Sun Sep 7 19:28:50 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/It_s_Slowtwitch_live_at_Life_Time__902.html: Sat Jul 11 00:04:04 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/It_s_Wildflower_time_and_ST_s_covering_it_live__781.html: Thu Apr 30 11:25:54 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/John_Dahlz_of_UC_Berkeley_apparent_Collegiate_National_men_s_winner__764.html: Sat Apr 18 12:25:21 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Kirsten_Sweetland_roars_back_from_injury_to_win_Mooloolaba_World_Cup_737.html: Sun Mar 29 08:39:05 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Kona_odds_-_the_men_563.html: Fri Oct 10 01:15:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Kriat._Tisseyre_take_Mooseman_70.3_1378.html: Sun Jun 6 13:09:22 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/L.A._Tri_coverage_underway__1053.html: Mon Oct 5 11:50:14 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Lebrun_McQuaid_win_Xterra_USA_titles_1041.html: Sun Sep 27 15:32:10 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Life_Time_coverage_ongoing_now_902.html: Sat Jul 11 07:34:32 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Live_Coverage_of_CapTex_Tri_ongoing_now_2097.html: Mon May 30 04:23:31 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Live_coverage_of_Avia_Wildflower_Triathlon__784.html: Sat May 2 12:59:36 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Live_coverage_of_the_Rev3Tri_ongoing_845.html: Sun Jun 7 00:10:47 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Luis_conquers_Junior_Mens_title_381.html: Thu Jun 5 10:42:25 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Marino_Vanhoenacker_is_ready_for_his_Kona_closeup__1576.html: Fri Oct 8 00:07:21 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/McCormack_Balding_overcome_Hainan_heat_wave_to_win_China_70.3__766.html: Sun Apr 19 05:20:55 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/McCormack_Wallenhorst_in_Austria_824.html: Sun May 24 05:51:48 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/McCormack_and_McClone_rule_Hawaii_70.3_375.html: Sun Jun 1 08:49:22 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/McLarty_top_man_at_Collegiate_Nationals__1995.html: Sat Apr 9 20:46:41 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Miami_5i50_1953.html: Sun Mar 20 07:52:27 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Moffat_crushes_Hy-Vee_field_884.html: Sat Jun 27 13:25:35 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Moffat_rules_Gold_Coast_Worlds_1016.html: Sun Sep 13 08:57:30 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Mooloolabe_to_Vendula_Frintova__1273.html: Sat Mar 27 21:41:26 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Mutscheller_and_Post_rule_Winter_Triathlon_World_Campionships_211.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Ohata_drug_positive_nets_6-year_ban_1061.html: Fri Oct 9 00:05:32 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Pontano_and_Shay-Kenney_rule_rainy_Ironman_Lake_Placid_439.html: Sun Jul 20 17:33:19 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Pontano_and_Stewart_on_top_in_Idaho_877.html: Mon Jun 22 00:04:04 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Potts_and_Cave_win_Escape_from_Alcatraz_383.html: Mon Jun 9 08:15:15 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Potts_and_Wellington_rule_Tmberman_70.3_476.html: Sun Aug 17 15:47:54 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/2007_BG_Triathlon_World_Cup_Beijing_preview_23.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/2007_Best_of_the_US_triathlon_results_70.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/2007_Ironman_World_Championships_Kona_start_list_39.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/2008_BG_Triathlon_World_Cup_races_55.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Bennett_and_Haskins_win_US_Open_Triathlon_81.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Bennett_and_Snowsill_win_2007_LA_Triathlon_10.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Breakaways_wind_and_fast_finishes_as_Whitfield_and_Ertel_win_the_2007_Cancun_BG_ITU_World_Cup_106.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Chrissie_Wellington_shocks_experts_as_she_wins_the_2007_Ford_Ironman_World_Championships._80.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Chrissie_Wellington_shocks_the_experts_as_she_wins_the_2007_Ford_Ironman_World_Championships._80.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Cigana_and_Blatchford_win_in_Phuket_145.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Colting_and_Armstrong_win_2007_Ultraman_Worlds_129.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Fernandes_finally_does_it_5.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Fernandes_on_fire_in_Beijing_30.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Galindez_and_Stewart_win_Ironman_70.3_Cancun_44.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Gemmell_and_Fernandes_victorious_in_Greece_67.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Germans_rule_Ironman_Florida_as_Vuckovic_and_Kraft_win_107.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Gomez_dominant_in_Beijing_31.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Hunter_and_Ertel_win_in_San_Francisco_115.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Last_big_race_weekend_in_2007_113.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Lebrun_and_Dibens_win_2007_XTERRA_UK_32.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Macca_wins_2007_Ford_Ironman_World_Championships_79.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/New_drafting_rule_for_2007_Ford_Ironman_World_Championships_57.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/New_drafting_rule_for_2007_Ford_Ironman_World_Champs_57.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Perez_and_Louison_take_charge_in_Monaco_12.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Plata_and_Lavelle_take_care_of_business_at_Pacific_Grove_11.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Potts_and_Carfrae_are_the_new_Ironman_70.3_World_Champions_114.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Potts_and_Carfrae_victorious_at_Ironman_70.3_World_Championships_114.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Potts_and_Carfrae_victorious_at_Ironman_70.3_Worlds_114.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Stoltz_and_Dibens_win_2007_Maui_XTERRA_Champs_101.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Stoltz_and_Whitmore_win_XTERRA_USA_Championships_54.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Tayama_and_Spirig_win_2007_Eilat_BG_World_Cup_143.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/The_bikes_of_the_Pros_in_Kona_84.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Top_Ironman_Hawaii_Finishers_Archive_58.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Twelsiek_and_Ferguson_fly_at_Ironman_Wisconsin_2007_7.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Unger_stuns_the_triathlon_world_6.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Vansteelant_and_Morrison_dominate_Duathlon_Worlds_91.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Vernay_and_Paul_win_Ironman_Western_Australia_144.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/Wasle_and_Batelier_victorious_at_XTERRA_Germany_2007_13.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/XTERRA_2008_America_Tour_schedule_137.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/XTERRA_Maui_preview_94.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Races/_2008_USA_Triathlon_National_Championship_Schedule_109.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_Dibens_take_Clearwater_09_1113.html: Sat Nov 14 14:00:28 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_and_Bij_De_Vaate_victorious_in_Arizona_618.html: Sun Nov 23 16:09:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_and_Bij_de_Vaate_victorious_in_Arizona_618.html: Mon Nov 24 00:05:34 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_and_Dibens_dominate_Wildflower_2010_1330.html: Sat May 1 19:32:19 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_and_Spirig_take_70.3_Monaco_crowns_508.html: Sun Sep 7 06:16:37 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Raelert_and_Spirig_take_Monaco__508.html: Sun Sep 7 08:21:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Reed_Carfrae_set_run_records_to_win_California_70.3__748.html: Sat Apr 4 15:48:09 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Reed_Dibens_strike_first_in_Knoxville_1337.html: Sun May 9 09:15:16 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Reed_and_Carfrae_on_top_in_California_748.html: Sat Apr 4 12:00:43 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Rhodes_and_Granger_claim_Ironman_Canada_487.html: Mon Aug 25 00:02:52 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Ryan_Barnett_insured_in_a_serious_accident_344.html: Tue May 6 12:33:50 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Ryan_Barnett_seriously_insured_344.html: Tue May 6 13:08:24 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Samantha_McGlone_s_quiet_return_1069.html: Mon Oct 12 00:04:57 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Shiver_unofficial_Collegiate_Women_s_winner_1996.html: Sat Apr 9 20:11:30 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Stoltz_Vanlandingham_take_XTERRA_West_titles_1318.html: Sun Apr 25 13:30:41 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Stoltz_and_McQuaid_in_Las_Vagas_785.html: Sun May 3 07:19:50 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Swail_Ertel_and_Reed_win_the_2008_USAT_Elite_Championships_532.html: Sun Sep 21 00:03:58 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Switzerland_repeats_at_ITU_Team_Worlds_1499.html: Sun Aug 22 09:39:31 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Team_Challenge_takes_2009_Barcelona_organizer_to_court_1188.html: Tue Feb 2 13:12:27 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Team_Challenge_takes_2009_Challenge_Barcelona_organizer_to_court_1188.html: Fri Jan 29 15:18:56 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/The_Oakley_Fast_Jacket_reveal_1586.html: Tue Oct 19 07:09:02 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/The_bikes_of_the_top_ten_pro_women_in_Kona_90.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/The_new_Slowtwitch3D_magazine_1279.html: Thu Apr 1 08:03:20 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/The_top_ten_pro_men_in_Kona_and_their_bikes_89.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/This_was_my_Kona__1804.html: Sun Nov 21 15:28:05 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Thompson_Jacobs_win_Powerman_Alabama_774.html: Sat Apr 25 00:09:30 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Thompson_and_Keat_victorious_in_Singapore_507.html: Mon Sep 8 00:03:03 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Tim_Hola_Rochelle_Hair_win_long_course_nationals_1030.html: Sat Sep 19 13:12:57 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Timo_Bracht_-_stealth_contender_1578.html: Fri Oct 8 00:07:22 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Top_field_for_Toyota_Cup_2nd_round_2090.html: Tue May 24 12:17:23 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Toyota_Dallas_is_live__1073.html: Sun Oct 11 05:25:23 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Triathlete_Magazine_to_be_part_of_big_venture_capital_acquisition_157.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Triathlon_end_of_year_news_roundup_1149.html: Mon Dec 21 00:05:20 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/USAT_Collegiate_Nationals_set_for_cold_windy_day_in_Lubbock_762.html: Fri Apr 17 00:09:12 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Ussher_Crawford_win_Challenge_Wanaka_1169.html: Sat Jan 16 00:05:15 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Vernay_repeats_and_Wellington_proves_a_point_299.html: Sun Apr 6 06:13:40 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/We_are_on_for_round_2_1421.html: Fri Jul 2 12:28:35 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Wellington_crushes_Alpe_d_Huez_Triathlon_453.html: Thu Jul 31 10:09:40 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/What_We_Have_Noticed_Biestmilch_Fizik_Trix_..._1853.html: Fri Jan 7 10:55:55 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/What_We_Have_Noticed_Cervellum_Tifosi_UA..._924.html: Tue Jul 21 07:41:56 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/What_We_Have_Noticed_Continental_blueseventy_Rafael_knog..._1520.html: Mon Sep 6 13:07:15 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/What_We_Have_Noticed_Lava_Panache_HoneyStinger..._1435.html: Thu Jul 15 08:45:43 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/What_We_Have_Noticed_TYR_Profile_Rapha_..._983.html: Tue Aug 25 05:15:22 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Whitfield_wins_six-man_Hy-Vee_finish_885.html: Sat Jun 27 17:42:08 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Winter_Tri_World_Championships_206.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Yoder_Naeth_take_Kemah_Tri_1981.html: Sun Apr 3 18:39:19 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Your_bike_flies_assembed_to_Kona_1481.html: Tue Aug 10 09:39:21 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/News/Zamora_Perez_and_Macel_survive_Embrunman_1491.html: Mon Aug 16 09:28:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Abu_Dhabi_Men_s_Odds_1938.html: Wed Mar 9 21:34:25 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Abu_Dhabi_Women_s_Odds_1940.html: Wed Mar 9 21:35:34 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Contenders_to_Watch_at_Wildflower_2025.html: Wed Apr 27 15:38:44 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Does_field_size_matter__323.html: Thu Apr 17 10:09:04 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Ironman_Hawaii_Women_s_Odds_2010_1566.html: Mon Oct 4 07:38:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Ironman_Hawaii_Women_s_Odds__1565.html: Sat Oct 2 10:24:38 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Oceanside_70.3_Odds_1266.html: Wed Mar 24 06:23:15 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Old_harriers_never_die..._933.html: Mon Jul 27 18:29:10 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Still_amateur_hour_atop_the_USOC_685.html: Mon Feb 9 00:07:23 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Opinion/Welcome_..._Again_..._to_Slowtwitch.com__42.html: Sat Mar 15 10:28:40 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/2009_tri_bikes_at_the_entry_level_668.html: Fri Feb 5 09:28:24 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/2010_Tri_bikes_992.html: Mon Aug 31 09:40:38 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/2nd_step_from_Felt_Orbea_707.html: Fri Feb 5 09:28:27 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/2nd_step_tri_bikes_695.html: Fri Feb 5 09:28:27 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/2nd_step_tri_from_Fuji_and_Giant_754.html: Fri Feb 5 09:28:28 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/A_sneak_peak_at_..._502.html: Fri Sep 5 10:36:01 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Entry-level_tri_bikes_Trek_and_Fuji_693.html: Fri Feb 5 09:28:27 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Felt_s_Devox_Aerobar_1407.html: Sat Jun 26 12:46:36 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/First_Look_2009_Zoot_Footwear_391.html: Sun Jun 15 00:02:16 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Javelin_Lugano_868.html: Fri Feb 5 00:04:03 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear/Lightweight_Running_Spring_09_634.html: Sat Jan 24 05:12:27 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear/Lightweight_Trainers_Part_3._656.html: Fri Jan 23 07:53:40 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear/Lightweight_Trainers_Part_3_656.html: Sat Jan 24 05:12:31 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear/More_lightweight_trainers_09_641.html: Sat Jan 24 05:12:28 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear/Running_footwear_09_racing_flats_669.html: Sat Jan 24 05:12:34 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Adidas_running_shoes/More_lightweight_trainers_09_641.html: Fri Feb 5 00:02:54 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Adidas_running_shoes/Stability_shoes_Part_1_692.html: Fri Feb 5 00:03:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Asics_running_shoes/Lightweight_Running_Spring_09_634.html: Fri Feb 5 00:02:51 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Asics_running_shoes/Motion_Control_footwear_2009_686.html: Fri Feb 5 00:03:09 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Asics_running_shoes/Running_footwear_09_racing_flats_669.html: Fri Feb 5 00:03:03 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Asics_running_shoes/Stability_shoes_Part_1_692.html: Fri Feb 5 00:03:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Avia_running_shoes/Stability_shoes_Part_1_692.html: Fri Feb 5 00:03:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Brooks_running_shoes/Lightweight_Trainers_Part_3_656.html: Fri Feb 5 00:02:58 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Brooks_running_shoes/Motion_Control_footwear_2009_686.html: Fri Feb 5 00:03:09 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Brooks_running_shoes/Running_footwear_09_racing_flats_669.html: Fri Feb 5 00:03:02 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Brooks_running_shoes/Stability_shoes_Part_1_692.html: Fri Feb 5 00:03:11 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/K-Swiss_running_shoes/K-Swiss_Konesic_1286.html: Tue Apr 6 11:30:43 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/K-Swiss_running_shoes/K-Swiss_Ultra-Ntrl_Run_ii_IM_1155.html: Wed Jan 6 10:54:46 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/K-Swiss_running_shoes/K-Swiss_Ultra_1155.html: Wed Jan 6 00:05:27 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/K-Swiss_running_shoes/Lightweight_Trainers_Part_3_656.html: Fri Feb 5 00:02:59 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Mizuno_running_shoes/More_lightweight_trainers_09_641.html: Fri Feb 5 00:02:54 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/New_Balance_running_shoes/More_lightweight_trainers_09_641.html: Fri Feb 5 00:02:54 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Newton_running_shoes/Lightweight_Trainers_Part_3_656.html: Fri Feb 5 00:02:59 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Nike_running_shoes/Lightweight_Running_Spring_09_634.html: Fri Feb 5 00:02:51 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Puma_running_shoes/Running_footwear_09_racing_flats_669.html: Fri Feb 5 00:03:03 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Saucony_running_shoes/Lightweight_Running_Spring_09_634.html: Fri Feb 5 00:02:51 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_brand/Stability_shoes_Part_1_692.html: Mon Feb 23 17:03:37 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Lightweight_Running_Spring_09_634.html: Mon Feb 23 00:07:03 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Lightweight_Trainers_Part_3_656.html: Mon Feb 23 00:07:10 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/More_lightweight_trainers_09_641.html: Mon Feb 23 00:07:05 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Motion_Control/K-Swiss_Konesic_1286.html: Tue Apr 6 11:30:43 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Motion_Control/Motion_Control_footwear_2009_686.html: Fri Feb 5 00:03:10 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Motion_Control_footwear_2009_686.html: Mon Feb 23 00:07:19 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral/Lightweight_Running_Spring_09_634.html: Mon Jan 4 07:48:19 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral/Lightweight_Trainers_Part_3_656.html: Mon Jan 4 08:02:39 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral/More_lightweight_trainers_09_641.html: Mon Jan 4 07:10:04 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral_Trainers/Lightweight_Running_Spring_09_634.html: Fri Feb 5 00:02:52 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral_Trainers/Lightweight_Trainers_Part_3_656.html: Fri Feb 5 00:02:59 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral_Trainers/More_lightweight_trainers_09_641.html: Fri Feb 5 00:02:54 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Neutral_Trainers/Newton_AW_1154.html: Fri Feb 5 08:39:35 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Racing/Running_footwear_09_racing_flats_669.html: Fri Feb 5 00:03:03 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Running_footwear_09_racing_flats_669.html: Mon Feb 23 00:07:14 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Stability/Stability_shoes_Part_1_692.html: Mon Jan 4 07:48:25 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Stability/Stability_shoes_Part_2_771.html: Mon Jan 4 00:03:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Structured_trainers/Stability_shoes_Part_1_692.html: Fri Feb 5 00:03:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Running_Footwear_by_type/Structured_trainers/Stability_shoes_Part_2_771.html: Fri Feb 5 00:03:35 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Sports_Electronics_Mailbag/DCR_Mailbag_2019.html: Tue Apr 19 09:54:39 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tech_footwear_demystifier_675.html: Mon Feb 23 00:07:17 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/The_Litespeed_Saber_of_David_Thompson_201.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Cervelo/Felt_B12_2010__1297.html: Mon Jan 3 00:07:46 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Felt/Felt_s_DA_white_paper_1472.html: Mon Aug 30 10:35:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Specialized/Jordan_Rapp_s_Specialized_Shiv_2036.html: Mon May 2 04:46:33 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Specialized/Specialized_Transition_Expert_2011__1848.html: Mon Jan 3 10:38:26 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Trek/Speed_Concept_Geometry_1383.html: Mon Aug 30 10:35:11 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Trek/Speed_Concept_Worth_buying__1391.html: Mon Aug 30 10:35:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_brand/Trek/Trek_Equinox_TTX_9.5_1177.html: Mon Aug 30 10:34:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/2010_Tri_bikes_992.html: Mon Aug 30 10:34:07 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2000-_2500/Felt_B14_2010__1295.html: Mon Aug 30 10:34:57 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2000-_2500/Felt_B16_for_2010_1145.html: Mon Aug 30 10:34:32 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2000-_2500/Quintana_Roo_Seduza_1144.html: Mon Aug 30 10:34:31 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2000-_2500/Slice_5_1157.html: Mon Aug 30 03:29:47 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2600-_3500/Cervelo_P2_2010__1296.html: Mon Aug 30 10:34:58 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2600-_3500/Felt_B12_2010__1297.html: Mon Aug 30 10:34:59 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2600-_3500/Scott_Plasma_30_2010__1312.html: Mon Aug 30 00:06:34 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2600-_3500/Transition_Comp_for_2010_1306.html: Mon Aug 30 10:35:01 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_2600-_3500/Trek_Equinox_TTX_9.0_2010__1310.html: Mon Aug 30 00:06:33 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_3600-_4500/Trek_Equinox_TTX_9.5_1177.html: Mon Aug 30 10:34:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_4600-_6400/Giant_s_Trinity_Advanced_SL2_1026.html: Mon Aug 30 10:34:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_4600-_6400/Ridley_Dean_1200.html: Mon Aug 30 10:34:40 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_4600-_6400/Scott_Plasma_10_for_2010_1258.html: Mon Aug 30 00:06:17 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_6500_and_up/Felt_s_2011_DA_1471.html: Mon Aug 30 10:35:36 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_6500_and_up/Javelin_Lugano_868.html: Mon Aug 30 03:29:30 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_under_1900/Giant_Trinity_0_for_2010_1003.html: Mon Aug 30 10:34:09 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_Bikes_under_1900/Giant_Trinity_1_for_2010_1004.html: Mon Aug 30 10:34:10 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_2600-_3500_2011_/Cannondale_Slice_3_2011__1531.html: Sun Sep 19 04:19:06 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_2600-_3500_2011_/Scott_Plasma_20_2011__1530.html: Sun Sep 19 04:19:05 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_2600-_3500_2011_/Specialized_Transition_Pro_1542.html: Sun Sep 19 04:19:09 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_2600-_3500_2011_/Trek_Speed_Concept_7.5_2011__1532.html: Sun Sep 19 04:19:06 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_2900-_3700_2011_/Specialized_Transition_Expert_2011__1848.html: Mon Jan 3 10:38:26 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Tri_Bike_by_price_/Tri_bikes_by_price_for_2011/Tri_Bikes_6500_and_up_2011_/Felt_s_2011_DA_1471.html: Sun Sep 19 04:18:52 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/Trinity_wraps_up_entry-level_tri_696.html: Fri Feb 27 13:19:49 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/What_We_Have_Noticed_Xtenex_Zipp_Avia_Fi_zi_k_657.html: Fri Jan 9 17:09:07 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/What_We_Have_Noticed_blueseventy_HED_Lynskey..._722.html: Sun Mar 15 00:07:59 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/What_are_the_big_road_teams_riding_now__503.html: Thu Sep 4 12:31:46 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Products/blueseventy_s_pointzero3_swim_skin_gets_FINA_approval._108.html: Sat Mar 15 10:28:42 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/Blame_China_if_your_rack_wobbles_1130.html: Mon Jan 4 00:05:14 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/Brick_by_brick_1001.html: Mon Sep 14 07:29:11 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/Five_minutes_with_The_Donald_1094.html: Mon Jan 4 00:05:05 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/Musselman_by_the_numbers_1139.html: Mon Jan 4 00:05:17 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/RD_Diary_Brick_by_brick_1001.html: Mon Jan 4 00:04:39 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/RD_Diary_One_Million_Revolutions_1033.html: Mon Jan 4 00:04:49 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/RD_Diary_Sign_up_now__1024.html: Mon Jan 4 00:04:46 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/RD_Diary_Talk_to_Jim_994.html: Mon Jan 4 00:04:37 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/RD_Diary_Willy_Loman_Triathlon_Peddler_1057.html: Mon Jan 4 00:04:55 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/The_Seven_Days_of_Mussel_1147.html: Mon Jan 4 00:05:19 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/The_Seven_Nags_1121.html: Mon Jan 4 00:05:12 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Henderson_s_RD_diary/Three_queries_for_a_hay_bale_1084.html: Mon Jan 4 00:05:02 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/RD_Aids/Race_Director_series_Getting_that_special_event_permit_232.html: Thu Apr 10 00:01:03 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Bike_geometry_225.html: Tue Nov 25 07:12:07 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Bikes_for_the_torso-impaired_220.html: Tue Nov 25 00:03:58 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Frame_sizing_problems_Part_II_Let_s_look_at_the_numbers_193.html: Tue Nov 25 07:12:02 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Frame_sizing_problems_Part_I_Beware_of_T-shirt_nomenclature_190.html: Tue Nov 25 07:12:01 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Memo_to_bike_maker_change_OE_spec__1399.html: Mon Jun 14 12:37:33 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/P4_in_the_Tunnel_1929.html: Fri Mar 4 11:00:37 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Remote_tri_bike_fit_607.html: Tue Nov 25 07:13:13 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Steering_geometry_for_tri_bikes_224.html: Tue Nov 25 00:03:59 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/The_Aerodynamics_of_hand_height_130.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/The_Aerodynamics_of_hand_height_132.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/The_Aerodynamics_of_hand_height_133.html: Sat Mar 15 10:28:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/The_Bike_from_the_bars_back_finale_339.html: Tue Nov 25 00:04:25 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Tech/Trek_s_White_Paper_2.0_-_The_Speed_Concept_1361.html: Mon Aug 30 10:35:08 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Aerobic_points_system_15.html: Sat Nov 22 00:03:12 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Ascending_215.html: Sat Nov 22 00:03:59 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Can_Yoga_Help_My_Race__739.html: Mon Jul 13 08:14:28 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Care_and_Feeding_of_your_wetsuit_257.html: Sat Nov 22 00:04:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Consistency_killers_769.html: Mon Jul 13 08:14:31 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Cycling/Defensive_cycling_362.html: Mon Jun 7 00:01:45 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Cycling/Tour_of_Sweden_1st_Day_on_the_road_809.html: Mon May 18 17:01:32 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Cycling/Tour_of_Sweden_training_camp_day_1_803.html: Sun May 17 09:42:22 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Defensive_cycling_362.html: Sat Nov 22 00:04:39 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Descending_203.html: Sat Nov 22 07:17:54 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Duathlon_Nationals_Challenge_678.html: Mon Jul 13 07:26:35 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/General_Physiology/Speedwork_Is_it_time_yet__811.html: Tue Jul 14 00:03:39 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/General_Training/Finding_Performance_1401.html: Thu Jun 17 09:59:26 2010 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Getting_the_darn_thing_on_and_off_256.html: Sat Nov 22 00:04:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Has_swimming_got_you_over_a_barrel__238.html: Sat Nov 22 00:04:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/How_much_is_too_much__387.html: Sat Nov 22 00:04:46 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/How_to_Kill_Your_10k_PR_258.html: Sat Nov 22 00:04:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Interval_Training_the_Hitchcock_way_259.html: Sat Nov 22 00:04:11 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Intro_to_Power_151.html: Sat Nov 22 07:17:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/It_s_the_principle_that_matters_263.html: Sat Nov 22 00:04:12 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Kicking_252.html: Sat Nov 22 00:04:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Masters_the_best_way_to_get_faster_253.html: Sat Nov 22 00:04:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Measuring_Power_and_Using_the_Data_302.html: Sat Nov 22 00:04:22 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Open_water_as_art_242.html: Sat Nov 22 00:04:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Open_water_etiquette_240.html: Sat Nov 22 00:04:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Open_water_miscellany_251.html: Sat Nov 22 00:04:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Open_water_tactics_255.html: Sat Nov 22 00:04:10 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Picklehead_241.html: Sat Nov 22 00:04:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Propulsion_in_the_water_249.html: Sat Nov 22 00:04:08 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Run_injury_free_261.html: Sat Nov 22 07:18:03 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Running/Open_water_miscellany_251.html: Mon Aug 3 10:50:46 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Running_long_for_improved_performance_260.html: Sat Nov 22 07:18:03 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Sheila_Taormina_s_Swim_Tips_250.html: Sat Nov 22 00:04:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Slowtwitch.com_s_training_log_goes_live_625.html: Mon Jul 13 08:14:21 2009 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Stalling_in_the_water_307.html: Sat Nov 22 00:04:23 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Stress-Induced_Pulmonary_Edema_SIPE__45.html: Sat Mar 15 10:28:43 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Swimming/How_To_Pull_Underwater_2006.html: Mon Apr 11 12:52:11 2011 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Swimming_Induced_Pulmonary_Edema_SIPE__45.html: Sat Nov 22 00:03:18 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Technical_aspects_of_running_262.html: Sat Nov 22 00:04:11 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/The_Basics_of_Ocean_Swimming_254.html: Sat Nov 22 00:04:09 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/The_Mathematics_of_Race_Fueling_200.html: Sat Nov 22 00:03:55 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/The_case_for_swimming_239.html: Sat Nov 22 00:04:06 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/The_muscles_used_in_freestyle_243.html: Sat Nov 22 00:04:07 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/The_softer_side_of_running_615.html: Sat Nov 22 00:05:57 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Top_masters_swim_coaches_tell_it_306.html: Sat Nov 22 00:04:23 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Training.Slowtwitch.Com_workout_log_goes_live_625.html: Tue Dec 2 10:07:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Trouble_in_the_open_water_450.html: Sat Nov 22 00:05:04 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Training/Where_the_Europeans_get_ready_346.html: Sat Nov 22 00:04:34 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Wrenchwork/A_Man-skills_workshop_228.html: Sat Mar 15 10:28:44 2008 (1308854026) +/var/home/slowtwitch/slowtwitch.com/www/Wrenchwork/Torque_wrenches_and_one_in_particualar__364.html: Mon May 26 10:29:08 2008 (1308854026) diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/remove_old_pages.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/remove_old_pages.cgi new file mode 100755 index 0000000..1e73f88 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/remove_old_pages.cgi @@ -0,0 +1,47 @@ +#!/usr/local/bin/perl + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +use File::stat; + +sub do_this { + my ($dir) = shift; + if (opendir DIR, $dir) { # it's a directory + for my $entry (sort readdir DIR) { + next if $entry eq "." or $entry eq ".."; + next if $entry =~ /New\//; + next if $dir =~ /New\//; + next if $entry =~ /images/; + next if -l "$dir/$entry"; + do_this("$dir/$entry"); # recurse + } + } + else { # it's a file + if ($dir =~ /_(\d+)\.html$/ and $dir !~ m,/New/, and $dir =~ m,www\/[A-Z],) { + my $sb = stat($dir); + my $time = time - 24*60*60; + if ($sb->mtime < $time) { + print $dir . ": "; + print scalar localtime $sb->mtime; + if (-f $dir) { + unlink $dir; + } + print " ($time)\n"; + } + + #printf "File is %s, size is %s, perm %04o, mtime %s\n", $dir, $sb->size, $sb->mode & 07777, scalar localtime $sb->mtime; + } + } +} + +do_this($CFG->{build_root_path}); # our top-level directory + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/rss.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/rss.cgi new file mode 100755 index 0000000..bf58ae2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/rss.cgi @@ -0,0 +1,126 @@ +#!/usr/local/bin/perl + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; +use Links::SiteHTML; +use GT::Date; +use XML::RSS; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { +# ------------------------------------------------------------------ +# Main admin loop, displays html pages and other admin tasks. +# + my @updates = get_recent_updates('Links', 'Add_Date', 'DESC', 10); + gen_rss(@updates); +} + +sub get_recent_updates { +# ------------------------------------------------------------------ +# Get recent news updates from the DB and return an array of hashes +# + my ($table, $sort_by, $sort_order, $limit) = @_; + my $db = $DB->table($table); + $db->select_options("ORDER BY $sort_by $sort_order", "LIMIT $limit"); + + my $sth = $db->select(); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link = Links::SiteHTML::tags('link',$link); + push @loop, { + description => $link->{Description}, + title => $link->{Title}, + link => $link->{detailed_url}, + }; + } + return @loop; +} + +sub gen_rss { +# ------------------------------------------------------------------ +# Generate the rss output file +# + my @updates = @_; + + use URI::Escape; + + my $date = GT::Date::date_get(time, "%yyyy%-%mm%-%dd%T%hh%:%mm%:%ss%%o%"); + $date =~ s/^(.*)(\d\d)$/$1:$2/; + + my $rss = XML::RSS->new(version => '1.0', encoding => 'iso-8859-1'); + $rss->channel( + title => 'Slowtwitch.com', + link => 'http://www.slowtwitch.com', + description => '', + dc => { + date => $date, + creator => 'Slowtwitch.com', + publisher => 'Slowtwitch.com', + rights => 'Copyright 2007, Slowtwitch.com', + language => 'en-us', + }, + syn => { + updatePeriod => 'daily', + updateFrequency => '1', + updateBase => $date, + } + ); + + $rss->image( + title => 'Slowtwitch.com', + url => 'http://www.slowtwitch.com/favicon.ico', + link => 'http://www.slowtwitch.com', + dc => { + creator => 'Slowtwitch.com' + } + ); + + foreach (@updates) { + my $t = escape_for_xml($_->{title}); + my $d = escape_for_xml($_->{description}); + + $rss->add_item( + title => $t, + link => $_->{link}, + description => $d, + ); + } + + $rss->save('/var/home/slowtwitch/slowtwitch.com/www/rss/slowtwitch.rss'); +} + +sub escape_for_xml { + my $text = shift; + + $text =~ s/\x82/,/g; + $text =~ s-\x83-f-g; + $text =~ s/\x84/,,/g; + $text =~ s/\x85/.../g; + + $text =~ s/\x88/^/g; + $text =~ s-\x89- °/°°-g; + + $text =~ s/\x8B/~-g; + $text =~ s-\x99-TM-g; + + $text =~ s/\x9B/>/g; + $text =~ s/\x9C/oe/g; + + return ""; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/settings.php b/site/slowtwitch.com/cgi-bin/articles/admin/settings.php new file mode 100644 index 0000000..4da1f8a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/settings.php @@ -0,0 +1,103 @@ +db_connect_id) { + echo "


        Error:


        + Connection to database failed
        +








        "; + + exit(); +} + +function get_sid() { + if (isset($_SESSION['cookie']) and $_SESSION['cookie']) { + return ''; + } + else { + return '&'.SID; + } +} + +function is_admin() { + if(is_logged_in($user)){ + $username = base64_decode($_SESSION['user']); + if ($username != "Slowman" && $username != "Rappstar" && $username != "Herbert" && $username != "Janitor" && $username != "gtvirginia" && $username != "AWright" && $username != "STConcierge") { + return false; + } else { + return true; + } + } else { + return false; + } +} + +//global function for checking whether user is logged in or not. +//you will notice we will use it everwhere in the script. +function is_logged_in($user) { + global $db,$prefix; + + // return true if we're already logged in + if (isset($_SESSION['user']) && $_SESSION['user'] != '') { + return 1; + } + + // try and get the session id + if (isset($_REQUEST['gforum_1022870964_session'])) { + $session_id = $_REQUEST['gforum_1022870964_session']; + } + else if ($_REQUEST['from'] == 'gforum') { + foreach ($_COOKIE as $key => $value) { + if (preg_match('/gforum.*session/', $key)) { + $session_id = $value; + break; + } + } + if (! isset($session_id)) { + return 0; + } + } + // return false if we have no login info + else { + return 0; + } + + $result = mysql_query("SELECT session_user_id FROM ".$prefix."Session WHERE session_id='$session_id'") or die (mysql_error()); + $row = mysql_fetch_array($result); + $user_id = $row['session_user_id']; + $result = mysql_query("SELECT user_username,user_password,user_last_logon FROM ".$prefix."User WHERE user_id='$user_id'"); + $row = mysql_fetch_array($result); + + $_SESSION['user'] = base64_encode($row['user_username']); + $_SESSION['password'] = base64_encode($row['user_password']); + $_SESSION['user_id'] = base64_encode($user_id); + $_SESSION['session_id'] = $session_id; + $_SESSION['cookie'] = !(isset($_REQUEST['session'])); + + if ($_SESSION['user_id'] == '') { return 0; } + + // we're now logged in, so return 1 + return 1; + + // TODO: SLOWTWITCH CHANGE END +} + +?> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/setup.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/setup.cgi new file mode 100755 index 0000000..3a0fe69 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/setup.cgi @@ -0,0 +1,451 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: setup.cgi,v 1.89 2009/05/08 19:56:50 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$IN $CFG $DB %STASH/; +use Links::SQL; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +main(); + +sub main { +# ------------------------------------------------------------------ +# Main admin loop, displays html pages and other admin tasks. +# + +# Make sure we are only run from the web. + if (! defined $ENV{REQUEST_METHOD}) { + print "\nThis script can only be accessed from your browser.\n\n"; + if ($CFG->{admin_root_url}) { + print "Try visiting:\n\t$CFG->{admin_root_url}/setup.cgi\n\n"; + } + return; + } + +# If we don't have anything to do, and aren't setup yet, go to setup_first template. + if (! $IN->param('do') and ! $CFG->{setup}) { + $IN->param('do', 'page'); + $IN->param('page', 'setup_first.html'); + } + +# If we can't find the admin templates, perhaps the path is screwed, try to +# reset it. + if (! -e "$CFG->{admin_root_path}/templates/admin") { + die 'Configured admin path does not appear to be valid!'; + } +# Otherwise do the command or display the setup frameset. + my $action = $IN->param('do') || 'disp_home'; + no strict 'refs'; my %subs = %{__PACKAGE__ . "::"}; use strict 'refs'; + + if (exists $subs{$action}) { + $subs{$action}->(); + } + elsif ($action eq 'page') { + Links::admin_page(); + } + else { + die "Invalid Request: '$action'"; + } +} + +sub setup_sql { +# ------------------------------------------------------------------ +# Change the sql server information. +# + my ($host, $port, $output, $action, $ret); + + $action = $IN->param('action'); + print $IN->header(); + if ($action !~ /^create|overwrite|load$/) { + return Links::admin_page('setup_sql.html', [ $IN, { error => "Invalid action: '$action'" }]); + } + + $host = $IN->param('host'); + ($host =~ s/\:(\d+)$//) and ($port = $1); + + my $prefix = $IN->param('prefix'); + $prefix =~ /^\w*$/ or return Links::admin_page('setup_sql.html', [ $IN, { error => "Invalid prefix: '$prefix'. Can only be letters, numbers and underscore." } ]); + + $DB->prefix($prefix); + $ret = $DB->set_connect({ + driver => scalar $IN->param('driver'), + host => $host, + port => $port, + database => scalar $IN->param('database'), + login => scalar $IN->param('login'), + password => scalar $IN->param('password'), + RaiseError => 0, + PrintError => 0 + }); + if (! defined $ret) { + return Links::admin_page('setup_sql.html', [$IN, { error => $GT::SQL::error }]); + } + if ($action eq 'create') { + $output = Links::SQL::tables('check'); + } + elsif ($action eq 'overwrite') { + $output = Links::SQL::tables('force'); +# Create the admin user. + my $db = $DB->table('Users'); + my $pass = join '', map { chr(65 + rand 57) } 1 .. 8; + $db->insert({ Username => 'admin', Password => $pass, Email => $CFG->{db_admin_email}, ReceiveMail => 'No', Status => 'Administrator' }); + } + elsif ($action eq 'load') { + $output = Links::SQL::load_from_sql(); + } + Links::admin_page('setup_sql.html', [$IN, { message_pre => $output }]); +} + +sub setup_path { +# ------------------------------------------------------------------ +# Set the path information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_path(0); + } + else { + _update_cfg(); + if ($IN->param('update_others')) { + $CFG->{build_images_url} = "$CFG->{build_root_url}/images"; + $CFG->{build_css_url} = "$CFG->{build_root_url}/links.css"; + $CFG->{build_new_path} = "$CFG->{build_root_path}/New"; + $CFG->{build_new_url} = "$CFG->{build_root_url}/New"; + $CFG->{build_cool_path} = "$CFG->{build_root_path}/Cool"; + $CFG->{build_cool_url} = "$CFG->{build_root_url}/Cool"; + $CFG->{build_ratings_path} = "$CFG->{build_root_path}/Ratings"; + $CFG->{build_ratings_url} = "$CFG->{build_root_url}/Ratings"; + $CFG->{build_detail_path} = "$CFG->{build_root_path}/Detailed"; + $CFG->{build_detail_url} = "$CFG->{build_root_url}/Detailed"; + } + } + $CFG->save(); + Links::admin_page('setup_path.html', [$IN, { message => "All paths and URL's have been updated successfully." }]); +} + +sub setup_build { +# ------------------------------------------------------------------ +# Set the build information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_build(1); + } + else { + _update_cfg(); + } + + $CFG->save(); + Links::admin_page('setup_build.html', [$IN, { message => "All build options have been updated successfully." }]); +} + +sub setup_user { +# ------------------------------------------------------------------ +# Set the user information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_user(1); + } + else { + _update_cfg(); + } + $CFG->save(); + Links::admin_page('setup_user.html', [$IN, { message => "All user options have been updated successfully." }]); +} + +sub setup_email { +# ------------------------------------------------------------------ +# Set the email information. +# + print $IN->header(); + + if ($IN->param('db_mail_path') and $IN->param('db_smtp_server')) { + Links::admin_page('setup_email.html', [$IN, { message => "You can not specify both an SMTP server and a path to sendmail!" }]); + return; + } + + if ($IN->param('reset_defaults')) { + $CFG->default_email(1); + } + else { + _update_cfg(); + } + $CFG->save(); + Links::admin_page('setup_email.html', [$IN, { message => "All email options have been updated successfully." }]); +} + +sub setup_search { +# ------------------------------------------------------------------ +# Set the email information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_search(1); + } + else { + _update_cfg(); + } + $CFG->save(); + Links::admin_page('setup_search.html', [$IN, { message => "All search options have been updated successfully." }]); +} + +sub setup_review { +# ------------------------------------------------------------------ +# Set the review information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_review(1); + } + else { + _update_cfg(); + } + $CFG->save(); + Links::admin_page('setup_review.html', [$IN, { message => "All review options have been updated successfully. " }]); +} + +sub setup_date { +# ------------------------------------------------------------------ +# Set the date information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_date(1); + } + else { + _update_cfg(); + } + $CFG->save(); + +# Reload the date module. + delete $STASH{date_loaded}; + Links::init_date; + Links::admin_page('setup_date.html', [$IN, { message => "All date options have been updated successfully." }]); +} + +sub setup_misc { +# ------------------------------------------------------------------ +# Set the misc information. +# + print $IN->header(); + + if ($IN->param('reset_defaults')) { + $CFG->default_misc(1); + } + else { + _update_cfg(); + } + $CFG->save(); + Links::admin_page('setup_misc.html', [$IN, { message => "All misc options have been updated successfully." }]); +} + +sub setup_pass { +# ------------------------------------------------------------------ +# Creates the .htaccess/.htpasswd file. +# + print $IN->header(); + + my $htpasswd = $CFG->{admin_root_path} . "/.htpasswd"; + my $htaccess = $CFG->{admin_root_path} . "/.htaccess"; + unless (-w $htaccess and -w $htpasswd) { + Links::admin_page('setup_pass.html', [$IN, { error => "Sorry, but we don't have write access to the htaccess files: '$htaccess' and '$htpasswd'." }]); + return; + } + + my $username = $IN->param('admin_username'); + my $password = $IN->param('admin_password'); + my $password2 = $IN->param('admin_password_confirm'); + my $to_delete = $IN->param('delete') ? $IN->param('delete_user') : $username; + + if ($password and $password ne $password2) { + Links::admin_page('setup_pass.html', [$IN, { error => "Your passwords do not match." }]); + return; + } + + my $fh = \do { local *FH; *FH }; + open $fh, "< $htpasswd" or die "Unable to open '$htpasswd': $!"; + my @lines = <$fh>; + close $fh; + @lines = grep ! /^\Q$to_delete\E:/, @lines if $to_delete; + + if ($username and $password) { + require GT::MD5::Crypt; + my $salt = join '', ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/')[map rand 64, 1 .. 8]; + my $crypted = GT::MD5::Crypt::apache_md5_crypt($password, $salt); + push @lines, "$username:$crypted\n"; + } + + if (@lines and -z $htaccess) { + _create_htaccess($htaccess, $htpasswd); + } + elsif (!@lines and -s $htaccess) { + open $fh, "> $htaccess"; + close $fh; + } + + open $fh, "> $htpasswd" or die "Unable to open '$htpasswd': $!"; + print $fh @lines if @lines; + close $fh; + + Links::admin_page('setup_pass.html', [$IN, { message => "Your directory is now password protected. The next screen you visit, you should be prompted for a password." } ]); +} + +sub _create_htaccess { +# ------------------------------------------------------------------ +# Creates the htaccess file. +# + my ($htaccess, $htpasswd) = @_; + open HTAC, "> $htaccess" or die "Unable to open '$htaccess': $!"; + print HTAC <header(); + +# Test the ability to create a def file. + unless (open TEST, "> $CFG->{admin_root_path}/defs/database.def") { + return Links::admin_page('setup_second.html', [$IN, { error => <{admin_root_path}/defs/.
        +Please make sure this directory exists, and is writeable by the server.
        +If this is the wrong directory, you will need to manually set the directory
        +in Links::Config::Data. Error was: $! +HTML + } + close TEST; + unlink "$CFG->{admin_root_path}/defs/database.def"; + +# Set the connection info. + $overwrite = $IN->param('overwrite') ? 'force' : 'check'; + $host = $IN->param('host'); + ($host =~ s/\:(\d+)$//) and ($port = $1); + + my $prefix = $IN->param('prefix'); + $prefix =~ /^\w*$/ or return Links::admin_page('setup_sql.html', [ $IN, { error => "Invalid prefix: '$prefix'. Can only be letters, numbers and underscore." } ]); + + $DB->prefix($prefix); + my $ret = $DB->set_connect({ + driver => scalar $IN->param('driver'), + host => $host, + port => $port, + database => scalar $IN->param('database'), + login => scalar $IN->param('login'), + password => scalar $IN->param('password'), + RaiseError => 0, + PrintError => 0 + }); + if (! defined $ret) { + return Links::admin_page('setup_second.html', [$IN, { error => $GT::SQL::error }]); + } +# Now let's create the tables. + eval { local $SIG{__DIE__}; require Links::SQL; }; + if ($@) { return Links::admin_page('setup_second.html', [ $IN, { error => "Unable to load Links::SQL module: $@\n" }]); } + + my $output = Links::SQL::tables($overwrite); + +# Update other paths and URL's. + $CFG->{build_css_url} = "$CFG->{build_root_url}/links.css"; + $CFG->{build_new_path} = "$CFG->{build_root_path}/New"; + $CFG->{build_new_url} = "$CFG->{build_root_url}/New"; + $CFG->{build_cool_path} = "$CFG->{build_root_path}/Cool"; + $CFG->{build_cool_url} = "$CFG->{build_root_url}/Cool"; + $CFG->{build_ratings_path} = "$CFG->{build_root_path}/Ratings"; + $CFG->{build_ratings_url} = "$CFG->{build_root_url}/Ratings"; + $CFG->{build_detail_path} = "$CFG->{build_root_path}/Detailed"; + $CFG->{build_detail_url} = "$CFG->{build_root_url}/Detailed"; + $CFG->{build_images_url} = "$CFG->{build_root_url}/images"; + +# Create the admin user. + my $db = $DB->table('Users'); + my $pass = $db->random_pass; + $db->insert({ Username => 'admin', Password => $pass, Email => $CFG->{db_admin_email}, ReceiveMail => 'No', Status => 'Administrator' }); + +# And lets set sensible defaults for the rest of the config vars. + $CFG->create_defaults(); + +# And save the config. + $CFG->save(); + Links::admin_page('setup_third.html', [ $IN, { message => "The data tables have been setup:
        $output
        " } ]); +} + +sub disp_home { +# ------------------------------------------------------------------ +# Display the home page. +# + print $IN->header(); + Links::admin_page('setup.html', $IN); +} + +sub reset_setup { +# ------------------------------------------------------------------ +# Sets the cfg->{setup} to 0, and prints out the setup_first page. +# + print $IN->header(); + + $CFG->{setup} = 0; + $CFG->save; + Links::admin_page('setup_first.html', $IN); +} + +sub _update_cfg { +# ------------------------------------------------------------------ +# Updates the config based on the form input. +# + for my $param ($IN->param) { + next unless exists $CFG->{$param}; + my $val = $IN->param($param); + if ($val eq 'custom' and my $custom = $IN->param("${param}_custom")) { + $CFG->{$param} = $custom; + } + elsif (ref $CFG->{$param} eq 'ARRAY') { + my @val = split /\s*[,\n]\s*/, $val; + $CFG->{$param} = \@val; + } + elsif (ref $CFG->{$param} eq 'HASH') { + my $h = {}; + my @pairs = split /\s*[,\n]\s*/, $val; + foreach my $pair (@pairs) { + my ($k, $v) = split /\s*=>?\s*/, $pair; + $h->{$k} = $v; + } + $CFG->{$param} = $h; + } + else { + $CFG->{$param} = $val; + } + } +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/.tplinfo b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/.tplinfo new file mode 100644 index 0000000..0c78082 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/.tplinfo @@ -0,0 +1,6 @@ +{ + inheritance => [ + '../browser', + '/home/slowtwitch/site/common/templates' + ] +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.css.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.css.diff.html new file mode 100644 index 0000000..fa866cd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.css.diff.html @@ -0,0 +1,33 @@ + + +Gossamer Links 3.0.0 -> 3.0.1 "luna" template set CSS diff + + + +
        +Index: luna.css
        +===================================================================
        +RCS file: /glinks/html/static/luna/luna.css,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- luna.css    4 Apr 2005 07:21:27 -0000       1.10
        ++++ luna.css    12 Apr 2005 22:39:35 -0000      1.11
        +@@ -123,3 +123,14 @@
        +   background: none;
        + }
        + */
        ++
        ++/* If you change the globals category_cols or home_category_cols, then you will
        ++need to change the width of the columns themselves.  Note that IE sometimes has
        ++problems if this value adds up to 100%, so keep the width a little under 100%.
        ++For example, if you changed category_cols to 3, then this example would set
        ++the width of the columns to 33% (99% total). */
        ++/*
        ++#category dl {
        ++  width: 33%;
        ++}
        ++*/
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.diff.html new file mode 100644 index 0000000..0f70e95 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.0-3.0.1.diff.html @@ -0,0 +1,981 @@ + + +Gossamer Links 3.0.0 -> 3.0.1 "luna" template set diff + + + +
        +Index: luna/add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/add_success.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/add_success.html       24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/add_success.html       14 Apr 2005 03:07:05 -0000      1.12
        +@@ -56,7 +56,7 @@
        + </div>
        +
        + <p>
        +-<%~if AutoValidate%>
        ++<%~if config.build_auto_validate%>
        +   Your link has been added to <%if Category_loop.length > 1%>the following categories: <%loop Category_loop%><%loop_value%><%unless last%>, <%endunless%><%endloop%><%else%><%Category%><%endif%>.
        + <%~else%>
        +   Thank you! We will send you an e-mail once your link has been validated.
        +Index: luna/bookmark_folder_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_add.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/bookmark_folder_add.html       24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/bookmark_folder_add.html       18 Apr 2005 21:39:36 -0000      1.12
        +@@ -26,13 +26,13 @@
        +   <div class="row required clear">
        +     <label for="my_folder_name" class="name">Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="my_folder_name"  name="my_folder_name" value="<%if my_folder_name%><%my_folder_name%><%endif%>" class="text" />
        ++      <input type="text" id="my_folder_name"  name="my_folder_name" value="<%if my_folder_name%><%escape_html my_folder_name%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +     <label for="my_folder_description" class="name">Description:</label>
        +     <div class="value">
        +-      <input type="text" id="my_folder_description" name="my_folder_description" value="<%if my_folder_description%><%my_folder_description%><%endif%>" class="text" />
        ++      <input type="text" id="my_folder_description" name="my_folder_description" value="<%if my_folder_description%><%escape_html my_folder_description%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +Index: luna/bookmark_folder_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_edit.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/bookmark_folder_edit.html      24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/bookmark_folder_edit.html      18 Apr 2005 21:39:36 -0000      1.12
        +@@ -23,17 +23,17 @@
        +
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="folder_edit" />
        +-  <input type="hidden" name="my_folder_id" value="<%my_folder_id%>" />
        ++  <input type="hidden" name="my_folder_id" value="<%escape_html my_folder_id%>" />
        +   <div class="row required clear">
        +     <label for="my_folder_name" class="name">Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="my_folder_name"  name="my_folder_name" value="<%if my_folder_name%><%my_folder_name%><%endif%>" class="text" />
        ++      <input type="text" id="my_folder_name"  name="my_folder_name" value="<%if my_folder_name%><%escape_html my_folder_name%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +     <label for="my_folder_description" class="name">Description:</label>
        +     <div class="value">
        +-      <input type="text" id="my_folder_description" name="my_folder_description" value="<%if my_folder_description%><%my_folder_description%><%endif%>" class="text" />
        ++      <input type="text" id="my_folder_description" name="my_folder_description" value="<%if my_folder_description%><%escape_html my_folder_description%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +Index: luna/bookmark_link_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_add.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -b -r1.15 -r1.16
        +--- luna/bookmark_link_add.html 24 Mar 2005 08:58:29 -0000      1.15
        ++++ luna/bookmark_link_add.html 18 Apr 2005 21:39:36 -0000      1.16
        +@@ -31,7 +31,7 @@
        +
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="link_add" />
        +-  <input type="hidden" name="my_link_id_fk" value="<%ID%>" />
        ++  <input type="hidden" name="my_link_id_fk" value="<%escape_html ID%>" />
        +   <div class="row clear">
        +     <label for="my_comment" class="name">Comments:</label>
        +     <div class="value">
        +@@ -42,10 +42,10 @@
        +     <label for="my_folder_id_fk" class="name">Folder:<%if Folders.length > 1%> <span>*</span><%endif%></label>
        +     <div class="value<%if Folders.length == 1%> wrappedtext<%endif%>">
        +     <%~if Folders.length == 1%>
        +-      <input type="hidden" name="my_folder_id_fk" value="<%Folders.0.my_folder_id%>" /><%Folders.0.my_folder_name%>
        ++      <input type="hidden" name="my_folder_id_fk" value="<%escape_html Folders.0.my_folder_id%>" /><%Folders.0.my_folder_name%>
        +     <%~else%>
        +       <select id="my_folder_id_fk" name="my_folder_id_fk">
        +-        <%loop Folders%><option value="<%my_folder_id%>"<%if my_folder_default%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        ++        <%loop Folders%><option value="<%escape_html my_folder_id%>"<%if my_folder_default%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        +       </select>
        +     <%~endif%>
        +     </div>
        +Index: luna/bookmark_link_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_edit.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -b -r1.15 -r1.16
        +--- luna/bookmark_link_edit.html        24 Mar 2005 08:58:29 -0000      1.15
        ++++ luna/bookmark_link_edit.html        18 Apr 2005 21:39:36 -0000      1.16
        +@@ -31,7 +31,7 @@
        +
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="edit_bookmark" />
        +-  <input type="hidden" name="id" value="<%ID%>" />
        ++  <input type="hidden" name="id" value="<%escape_html ID%>" />
        +   <div class="row clear">
        +     <label for="my_comment" class="name">Comments:</label>
        +     <div class="value">
        +@@ -42,10 +42,10 @@
        +     <label for="my_folder_id_fk" class="name">Folder:<%if Folders.length > 1%> <span>*</span><%endif%></label>
        +     <div class="value<%if Folders.length == 1%> wrappedtext<%endif%>">
        +     <%~if Folders.length == 1%>
        +-      <input type="hidden" name="my_folder_id_fk" value="<%Folders.0.my_folder_id%>" /><%Folders.0.my_folder_name%>
        ++      <input type="hidden" name="my_folder_id_fk" value="<%escape_html Folders.0.my_folder_id%>" /><%Folders.0.my_folder_name%>
        +     <%~else%>
        +       <select id="my_folder_id_fk" name="my_folder_id_fk">
        +-        <%loop Folders%><option value="<%my_folder_id%>"<%if my_folder_default%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        ++        <%loop Folders%><option value="<%escape_html my_folder_id%>"<%if my_folder_default%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        +       </select>
        +     <%~endif%>
        +     </div>
        +Index: luna/bookmark_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_list.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -b -r1.12 -r1.13
        +--- luna/bookmark_list.html     24 Mar 2005 08:58:29 -0000      1.12
        ++++ luna/bookmark_list.html     18 Apr 2005 21:39:36 -0000      1.13
        +@@ -56,9 +56,9 @@
        + <%if Bookmarks.length~%>
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="links_manage" />
        +-  <input type="hidden" name="my_folder_id" value="<%my_folder_id%>" />
        ++  <input type="hidden" name="my_folder_id" value="<%escape_html my_folder_id%>" />
        + <%~loop Bookmarks%>
        +-  <input type="checkbox" name="m-id" value="<%ID%>" class="checkbox" />
        ++  <input type="checkbox" name="m-id" value="<%escape_html ID%>" class="checkbox" />
        + <%~set editable = 1%>
        + <%include bookmark_link.html%>
        + <%~endloop%>
        +@@ -66,7 +66,7 @@
        + <%~if folder_select.length%>
        +   <input type="submit" name="move" value="Move Links to" class="submit" />
        +   <select name="move_folderid">
        +-    <%loop folder_select%><option value="<%my_folder_id%>"><%my_folder_name%></option><%endloop%>
        ++    <%loop folder_select%><option value="<%escape_html my_folder_id%>"><%my_folder_name%></option><%endloop%>
        +   </select>
        + <%~endif%>
        + </form>
        +Index: luna/bookmark_preferences.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_preferences.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -b -r1.12 -r1.13
        +--- luna/bookmark_preferences.html      24 Mar 2005 08:58:29 -0000      1.12
        ++++ luna/bookmark_preferences.html      18 Apr 2005 21:39:36 -0000      1.13
        +@@ -53,7 +53,7 @@
        +   <div class="row clear">
        +     <label for="PerPage" class="name">Links Per Page:</label>
        +     <div class="value">
        +-      <input type="text" id="PerPage" name="PerPage" value="<%PerPage%>" class="text shorttext" />
        ++      <input type="text" id="PerPage" name="PerPage" value="<%escape_html PerPage%>" class="text shorttext" />
        +     </div>
        +   </div>
        +   <div class="formsubmit">
        +Index: luna/category.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.22
        +retrieving revision 1.26
        +diff -u -b -r1.22 -r1.26
        +--- luna/category.html  29 Mar 2005 09:51:43 -0000      1.22
        ++++ luna/category.html  13 Apr 2005 19:39:01 -0000      1.26
        +@@ -28,8 +28,8 @@
        + <div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>
        +   <%category_short%>
        +-<%~if config.newsletter_enabled%>
        +-  <%~Links::Newsletter::subscription_info($ID)%>
        ++<%~if config.newsletter_enabled and not config.newsletter_global_subscribe%>
        ++  <%~Links::Newsletter::subscription_info($ID)%><%-- SubscriptionStatus: 0 = not subscribed, 1 = indirectly subscribed, 2 = directly subscribed --%>
        +   <%if SubscriptionStatus == 2%><span class="hsmall">(<a href="<%config.db_cgi_url%>/subscribe.cgi?action=unsubscribe;ID=<%ID%>" title="Unsubscribe to stop getting updates from this category">Unsubscribe</a>)</span><%elsif SubscriptionStatus == 1%><%else%><span class="hsmall">(<a href="<%config.db_cgi_url%>/subscribe.cgi?action=subscribe;ID=<%ID%>" title="Subscribe to get updates from this category">Subscribe</a>)</span><%endif%>
        + <%~endif%>
        + </h2>
        +Index: luna/include_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_form.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -b -r1.9 -r1.10
        +--- luna/include_form.html      16 Mar 2005 08:44:37 -0000      1.9
        ++++ luna/include_form.html      18 Apr 2005 21:39:36 -0000      1.10
        +@@ -1,13 +1,13 @@
        + <div class="row required clear">
        +   <label for="Title" class="name">Title: <span>*</span></label>
        +   <div class="value">
        +-    <input type="text" id="Title" name="Title" value="<%if Title%><%Title%><%endif%>" class="text" />
        ++    <input type="text" id="Title" name="Title" value="<%if Title%><%escape_html Title%><%endif%>" class="text" />
        +   </div>
        + </div>
        + <div class="row required clear">
        +   <label for="URL" class="name">URL: <span>*</span></label>
        +   <div class="value">
        +-    <input type="text" id="URL" name="URL" value="<%if URL%><%URL%><%else%>http://<%endif%>" class="text" />
        ++    <input type="text" id="URL" name="URL" value="<%if URL%><%escape_html URL%><%else%>http://<%endif%>" class="text" />
        +   </div>
        + </div>
        + <div class="row<%unless category_loop_selected%> required<%endunless%> clear">
        +@@ -15,14 +15,14 @@
        +   <div class="value<%if category_loop_selected%> wrappedtext<%endif%>">
        +   <%if category_loop_selected%>
        +     <%if category_loop.length > 1%>
        +-    <ul><%loop category_loop%><li><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%ID%>" /></li><%endloop%></ul>
        ++    <ul><%loop category_loop%><li><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" /></li><%endloop%></ul>
        +     <%else%>
        +-    <%loop category_loop%><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%ID%>" /><%endloop%>
        ++    <%loop category_loop%><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" /><%endloop%>
        +     <%endif%>
        +   <%else%>
        +     <select id="CatLinks.CategoryID" name="CatLinks.CategoryID">
        +       <%loop category_loop%>
        +-      <option value="<%ID%>"<%if selected%> selected="selected"<%endif%>><%'&nbsp;&nbsp;' x $CatDepth%><%Name%></option>
        ++      <option value="<%escape_html ID%>"<%if selected%> selected="selected"<%endif%>><%'&nbsp;&nbsp;' x $CatDepth%><%Name%></option>
        +       <%endloop%>
        +     </select>
        +   <%endif%>
        +@@ -31,18 +31,18 @@
        + <div class="row clear">
        +   <label for="Description" class="name">Description:</label>
        +   <div class="value">
        +-    <textarea id="Description" name="Description" rows="3" cols="42"><%if Description%><%Description%><%endif%></textarea>
        ++    <textarea id="Description" name="Description" rows="3" cols="42"><%if Description%><%escape_html Description%><%endif%></textarea>
        +   </div>
        + </div>
        + <div class="row clear">
        +   <label for="Contact_Name" class="name">Contact Name:</label>
        +   <div class="value">
        +-    <input type="text" id="Contact_Name" name="Contact_Name" value="<%if Contact_Name%><%Contact_Name%><%endif%>" class="text" />
        ++    <input type="text" id="Contact_Name" name="Contact_Name" value="<%if Contact_Name%><%escape_html Contact_Name%><%endif%>" class="text" />
        +   </div>
        + </div>
        + <div class="row clear">
        +   <label for="Contact_Email" class="name">Contact E-mail:</label>
        +   <div class="value">
        +-    <input type="text" id="Contact_Email" name="Contact_Email" value="<%if Contact_Email%><%Contact_Email%><%endif%>" class="text" />
        ++    <input type="text" id="Contact_Email" name="Contact_Email" value="<%if Contact_Email%><%escape_html Contact_Email%><%endif%>" class="text" />
        +   </div>
        + </div>
        +Index: luna/include_header.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_header.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/include_header.html    1 Apr 2005 02:54:08 -0000       1.11
        ++++ luna/include_header.html    18 Apr 2005 21:39:36 -0000      1.12
        +@@ -20,8 +20,8 @@
        + <div class="searchbar">
        +   <form action="<%config.db_cgi_url%>/search.cgi">
        +     <label for="searchbox">Search</label>
        +-    <%if category_id%><input type="radio" id="searchentire" name="catid" value="" checked="checked" /><label for="searchentire">the entire directory</label> <input type="radio" id="searchcat" name="catid" value="<%category_id%>" /><label for="searchcat">only this category</label><%endif%>
        +-    <input type="text" id="searchbox" name="query" value="<%if query%><%query%><%endif%>" class="text" /><input type="submit" name="Go" value="Go" class="submit" /> <a href="<%config.db_cgi_url%>/search.cgi">Advanced Search</a>
        ++    <%if category_id%><input type="radio" id="searchentire" name="catid" value="" checked="checked" /><label for="searchentire">the entire directory</label> <input type="radio" id="searchcat" name="catid" value="<%escape_html category_id%>" /><label for="searchcat">only this category</label><%endif%>
        ++    <input type="text" id="searchbox" name="query" value="<%if query%><%escape_html query%><%endif%>" class="text" /><input type="submit" name="Go" value="Go" class="submit" /> <a href="<%config.db_cgi_url%>/search.cgi">Advanced Search</a>
        +   </form>
        + </div>
        + <hr class="hide" />
        +Index: luna/language.txt
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/language.txt,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -b -r1.16 -r1.17
        +--- luna/language.txt   4 Apr 2005 22:39:55 -0000       1.16
        ++++ luna/language.txt   15 Apr 2005 03:32:10 -0000      1.17
        +@@ -148,6 +148,7 @@
        +        'REVIEW_INVALIDID' => 'Invalid Link ID : %s.',
        +        'REVIEW_INVALID_ACTION' => 'Invalid action!',
        +        'REVIEW_INVALID_UPDATE' => 'Unable to update review database. User is invalid for this review or the review is not validated.',
        ++       'REVIEW_MODIFY_DENIED' => 'You have already reviewed this link.  Reviews cannot be modified.',
        +        'REVIEW_NORESULTS' => 'No reviews are available.',
        +        'REVIEW_NOT_EXISTS' => 'Review doesn\'t exist!',
        +        'REVIEW_RATING' => 'Please select a rating from 1 to 5 only.',
        +Index: luna/login.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login.html,v
        +retrieving revision 1.12
        +retrieving revision 1.15
        +diff -u -b -r1.12 -r1.15
        +--- luna/login.html     24 Mar 2005 08:58:29 -0000      1.12
        ++++ luna/login.html     18 Apr 2005 21:39:36 -0000      1.15
        +@@ -25,12 +25,12 @@
        +
        + <form action="<%config.db_cgi_url%>/user.cgi" method="post">
        +   <input type="hidden" name="login" value="1" />
        +-  <%if url%><input type="hidden" name="url" value="<%url%>" /><%endif%>
        ++  <%if url%><input type="hidden" name="url" value="<%escape_html url%>" /><%endif%>
        +
        +   <div class="row required clear">
        +     <label for="Username" class="name">Username:</label>
        +     <div class="value">
        +-      <input type="text" id="Username" name="Username" value="<%if Username%><%Username%><%endif%>" class="text" />
        ++      <input type="text" id="Username" name="Username" value="<%if Username%><%escape_html Username%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required clear">
        +Index: luna/login_email.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login_email.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -b -r1.10 -r1.11
        +--- luna/login_email.html       24 Mar 2005 08:58:29 -0000      1.10
        ++++ luna/login_email.html       18 Apr 2005 21:39:36 -0000      1.11
        +@@ -26,7 +26,7 @@
        +
        + <form action="<%config.db_cgi_url%>/user.cgi" method="post">
        +   <input type="hidden" name="send_pass" value="1" />
        +-  <%if url%><input type="hidden" name="url" value="<%url%>" /><%endif%>
        ++  <%if url%><input type="hidden" name="url" value="<%escape_html url%>" /><%endif%>
        +
        +   <div class="row required clear">
        +     <label for="Email" class="name">E-mail Address:</label>
        +Index: luna/modify.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -b -r1.9 -r1.10
        +--- luna/modify.html    24 Mar 2005 08:58:29 -0000      1.9
        ++++ luna/modify.html    18 Apr 2005 21:39:36 -0000      1.10
        +@@ -23,10 +23,10 @@
        + <form action="<%config.db_cgi_url%>/modify.cgi" enctype="multipart/form-data" method="post">
        +   <input type="hidden" name="modify" value="1" />
        + <%~if LinkID%>
        +-  <input type="hidden" name="LinkID" value="<%LinkID%>" />
        ++  <input type="hidden" name="LinkID" value="<%escape_html LinkID%>" />
        + <%~else%>
        +   Please enter the URL of the link you wish to modify. Make sure it is identical to the one already in the database:
        +-  <input type="text" name="Current_URL" value="<%if Current_URL%><%Current_URL%><%endif%>" class="text" />
        ++  <input type="text" name="Current_URL" value="<%if Current_URL%><%escape_html Current_URL%><%endif%>" class="text" />
        +   Now enter the new information (all of it, not just the changes) below:
        + <%~endif%>
        + <%include include_form.html%>
        +Index: luna/modify_select.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify_select.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -b -r1.12 -r1.13
        +--- luna/modify_select.html     24 Mar 2005 08:58:29 -0000      1.12
        ++++ luna/modify_select.html     18 Apr 2005 21:39:36 -0000      1.13
        +@@ -34,7 +34,7 @@
        +
        + <form action="<%config.db_cgi_url%>/modify.cgi" method="post">
        + <%~loop link_results_loop%>
        +-  <input type="radio" name="LinkID" value="<%ID%>" class="radio"<%if isValidated eq 'No'%> disabled="disabled"<%endif%> />
        ++  <input type="radio" name="LinkID" value="<%escape_html ID%>" class="radio"<%if isValidated eq 'No'%> disabled="disabled"<%endif%> />
        + <%include link.html%>
        + <%~endloop%>
        +   <input type="submit" value="Modify Link" class="submit" />
        +Index: luna/newsletter_browse.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_browse.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -b -r1.13 -r1.14
        +--- luna/newsletter_browse.html 24 Mar 2005 08:58:29 -0000      1.13
        ++++ luna/newsletter_browse.html 18 Apr 2005 21:39:36 -0000      1.14
        +@@ -87,9 +87,9 @@
        +
        + <form id="update" action="<%config.db_cgi_url%>/subscribe.cgi" method="post">
        +   <input type="hidden" name="action" value="update" />
        +-  <%if root%><input type="hidden" name="root" value="<%root%>" /><%endif%>
        ++  <%if root%><input type="hidden" name="root" value="<%escape_html root%>" /><%endif%>
        + <%~loop category%>
        +-  <input type="checkbox" name="S<%ID%>" value="<%ID%><%if Children.length%>,<%endif%><%loop Children%><%loop_value%><%unless last%>,<%endunless%><%endloop%>"<%if Subscribed%> checked="checked"<%endif%> class="indent<%CatDepth%>" /><input type="hidden" name="<%if Subscribed%>subscribed<%else%>unsubscribed<%endif%>" value="<%ID%>" /><%if HasMoreChildren%><a href="<%config.db_cgi_url%>/subscribe.cgi?action=browse;root=<%ID%>"><%endif%><%Name%><%if HasMoreChildren%></a><%endif%><br />
        ++  <input type="checkbox" name="S<%ID%>" value="<%escape_html ID%><%if Children.length%>,<%endif%><%loop Children%><%loop_value%><%unless last%>,<%endunless%><%endloop%>"<%if Subscribed%> checked="checked"<%endif%> class="indent<%CatDepth%>" /><input type="hidden" name="<%if Subscribed%>subscribed<%else%>unsubscribed<%endif%>" value="<%escape_html ID%>" /><%if HasMoreChildren%><a href="<%config.db_cgi_url%>/subscribe.cgi?action=browse;root=<%ID%>"><%endif%><%Name%><%if HasMoreChildren%></a><%endif%><br />
        + <%~endloop%>
        +   <input type="submit" value="Update Subscriptions" class="submit" />
        + </form>
        +Index: luna/newsletter_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_list.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -b -r1.13 -r1.14
        +--- luna/newsletter_list.html   24 Mar 2005 08:58:29 -0000      1.13
        ++++ luna/newsletter_list.html   18 Apr 2005 21:39:36 -0000      1.14
        +@@ -39,7 +39,7 @@
        +   <input type="hidden" name="page" value="newsletter_list" />
        +   <%if subscribed.length > 1%><input type="checkbox" id="checkall" class="checkbox" /> <label for="checkall"><strong>Select All</strong></label><br /><%endif%>
        + <%loop subscribed~%>
        +-  <input type="checkbox" id="ID-<%CategoryID%>" name="ID" value="<%CategoryID%>" class="checkbox" /> <label for="ID-<%CategoryID%>"><%Full_Name%></label><br />
        ++  <input type="checkbox" id="ID-<%CategoryID%>" name="ID" value="<%escape_html CategoryID%>" class="checkbox" /> <label for="ID-<%CategoryID%>"><%Full_Name%></label><br />
        + <%~endloop%>
        +   <input type="submit" value="Unsubscribe" class="submit" />
        + </form>
        +Index: luna/payment.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -b -r1.10 -r1.11
        +--- luna/payment.html   24 Mar 2005 08:58:29 -0000      1.10
        ++++ luna/payment.html   18 Apr 2005 21:39:36 -0000      1.11
        +@@ -49,8 +49,8 @@
        +   <input type="hidden" name="do" value="payment_method" />
        +   <input type="hidden" name="last_step" value="term" />
        +   <input type="hidden" name="last_page" value="payment" />
        +-  <input type="hidden" name="cat_id" value="<%cat_id%>" />
        +-  <input type="hidden" name="link_id" value="<%link_id%>" />
        ++  <input type="hidden" name="cat_id" value="<%escape_html cat_id%>" />
        ++  <input type="hidden" name="link_id" value="<%escape_html link_id%>" />
        +   <%if modify%><input type="hidden" name="modify" value="1" /><%endif%>
        +
        + <%if signup and not wasPaid%>
        +@@ -63,7 +63,7 @@
        +     <%~endif%>
        +     </strong><br />
        +   <%~loop signup%>
        +-    <input type="radio" id="payment_term-<%term%>" name="payment_term" value="<%term%>"<%if last_chosen and last_chosen eq $term and not last_recurring%> checked="checked"<%endif%> class="radio" />
        ++    <input type="radio" id="payment_term-<%term%>" name="payment_term" value="<%escape_html term%>"<%if last_chosen and last_chosen eq $term and not last_recurring%> checked="checked"<%endif%> class="radio" />
        +     <label for="payment_term-<%term%>"><%Links::Payment::currency($cost)%>: <%if term_num and term_unit%><%term_num%> <%term_unit%><%else%>Lifetime<%endif%></label><br />
        +   <%~endloop%>
        +   </p>
        +@@ -80,7 +80,7 @@
        +   <%~endif%>
        +
        + <%~loop renewal%>
        +-  <%if wasPaid%><input type="radio" id="payment_term-<%term%>" name="payment_term" value="<%term%>"<%if last_chosen and last_chosen eq $term and not last_recurring%> checked="checked"<%endif%> class="radio" /><%endif%>
        ++  <%if wasPaid%><input type="radio" id="payment_term-<%term%>" name="payment_term" value="<%escape_html term%>"<%if last_chosen and last_chosen eq $term and not last_recurring%> checked="checked"<%endif%> class="radio" /><%endif%>
        +   <%if wasPaid%><label for="payment_term-<%term%>"><%endif%><%Links::Payment::currency($cost)%>: <%if term_num and term_unit%><%term_num%> <%term_unit%><%else%>Lifetime<%endif%><%if wasPaid%></label><%endif%><br />
        + <%~endloop%>
        +   </p>
        +@@ -90,7 +90,7 @@
        +   <p>
        +     <strong>Automatically recurring payments:</strong><br />
        +   <%~loop recurring%>
        +-    <input type="radio" id="payment_term-<%term%>-rec" name="payment_term" value="<%term%>-rec"<%if last_chosen and last_chosen eq $term and last_recurring%> checked="checked"<%endif%> class="radio" />
        ++    <input type="radio" id="payment_term-<%term%>-rec" name="payment_term" value="<%escape_html term%>-rec"<%if last_chosen and last_chosen eq $term and last_recurring%> checked="checked"<%endif%> class="radio" />
        +     <label for="payment_term-<%term%>-rec"><%Links::Payment::currency($cost)%> <%if term_num == 1%>per <%term_unit%><%else%> every <%term_num%> <%term_unit%><%endif%></label><br />
        +   <%~endloop%>
        +   </p>
        +Index: luna/payment_2checkout_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_2checkout_include.html,v
        +retrieving revision 1.2
        +retrieving revision 1.3
        +diff -u -b -r1.2 -r1.3
        +--- luna/payment_2checkout_include.html 1 Feb 2005 01:13:21 -0000       1.2
        ++++ luna/payment_2checkout_include.html 18 Apr 2005 21:39:36 -0000      1.3
        +@@ -1,6 +1,6 @@
        + <form action="https://www.2checkout.com/cgi-bin/sbuyers/cartpurchase.2c" method="post">
        +-  <input type="hidden" name="sid" value="<%seller_id%>" />
        +-  <input type="hidden" name="total" value="<%payment_amount%>" />
        +-  <input type="hidden" name="cart_order_id" value="<%unique_id%>" />
        ++  <input type="hidden" name="sid" value="<%escape_html seller_id%>" />
        ++  <input type="hidden" name="total" value="<%escape_html payment_amount%>" />
        ++  <input type="hidden" name="cart_order_id" value="<%escape_html unique_id%>" />
        +   <input type="submit" value="Make Payment" class="submit" />
        + </form>
        +Index: luna/payment_direct.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_direct.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/payment_direct.html    24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/payment_direct.html    14 Apr 2005 03:16:50 -0000      1.12
        +@@ -21,9 +21,11 @@
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment Confirmation</h2>
        +
        +-Your payment has been approved, and your link enabled.  You will be redirected
        +-to the main page shortly.  If this does not happen, click
        +-<a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++<p>
        ++  Your payment has been approved, and your link enabled.  You will be redirected
        ++  to the main page shortly.  If this does not happen, click
        ++  <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++</p>
        +
        +             </div>
        +           </div>
        +Index: luna/payment_direct_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_direct_include.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -b -r1.9 -r1.10
        +--- luna/payment_direct_include.html    16 Mar 2005 08:44:37 -0000      1.9
        ++++ luna/payment_direct_include.html    18 Apr 2005 21:39:36 -0000      1.10
        +@@ -13,11 +13,11 @@
        +   <input type="hidden" name="do" value="payment_direct" />
        +   <input type="hidden" name="last_step" value="form" />
        +   <input type="hidden" name="last_page" value="payment_form" />
        +-  <input type="hidden" name="cat_id" value="<%cat_id%>" />
        +-  <input type="hidden" name="link_id" value="<%link_id%>" />
        +-  <input type="hidden" name="payment_term" value="<%payment_term%>" />
        +-  <input type="hidden" name="payment_method" value="<%payment_method%>" />
        +-  <input type="hidden" name="payment_method_type" value="<%payment_method_type%>" />
        ++  <input type="hidden" name="cat_id" value="<%escape_html cat_id%>" />
        ++  <input type="hidden" name="link_id" value="<%escape_html link_id%>" />
        ++  <input type="hidden" name="payment_term" value="<%escape_html payment_term%>" />
        ++  <input type="hidden" name="payment_method" value="<%escape_html payment_method%>" />
        ++  <input type="hidden" name="payment_method_type" value="<%escape_html payment_method_type%>" />
        +   <%if modify%><input type="hidden" name="modify" value="1" /><%endif%>
        +
        +   <div class="row<%unless no_cc_brand%> required<%endunless%><%if credit_card_brand_error%> invalid<%endif%> clear">
        +@@ -27,7 +27,7 @@
        +       <%loop payment_types%><%name%><%unless last%>, <%endunless%><%endloop%>
        +     <%else%>
        +       <select id="credit_card_brand" name="credit_card_brand">
        +-        <option value="">---</option><%loop payment_types%><option value="<%code%>"<%if credit_card_brand eq $code%> selected="selected"<%endif%>><%name%></option><%endloop%>
        ++        <option value="">---</option><%loop payment_types%><option value="<%escape_html code%>"<%if credit_card_brand eq $code%> selected="selected"<%endif%>><%name%></option><%endloop%>
        +       </select>
        +     <%endif%>
        +     </div>
        +@@ -35,7 +35,7 @@
        +   <div class="row required<%if credit_card_number_error%> invalid<%endif%> clear">
        +     <label for="credit_card_number" class="name">Card Number: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="credit_card_number" name="credit_card_number" value="<%if credit_card_number%><%credit_card_number%><%endif%>" class="text" autocomplete="off" />
        ++      <input type="text" id="credit_card_number" name="credit_card_number" value="<%if credit_card_number%><%escape_html credit_card_number%><%endif%>" class="text" autocomplete="off" />
        +     </div>
        +   </div>
        +   <div class="row required<%if credit_card_expiry_error%> invalid<%endif%> clear">
        +@@ -66,25 +66,25 @@
        +   <div class="row required<%if billing_fname_error%> invalid<%endif%> clear">
        +     <label for="billing_fname" class="name">First Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="billing_fname" name="billing_fname" value="<%if billing_fname%><%billing_fname%><%endif%>" class="text" />
        ++      <input type="text" id="billing_fname" name="billing_fname" value="<%if billing_fname%><%escape_html billing_fname%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required<%if billing_lname_error%> invalid<%endif%> clear">
        +     <label for="billing_lname" class="name">Last Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="billing_lname" name="billing_lname" value="<%if billing_lname%><%billing_lname%><%endif%>" class="text" />
        ++      <input type="text" id="billing_lname" name="billing_lname" value="<%if billing_lname%><%escape_html billing_lname%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required<%if billing_address_1_error%> invalid<%endif%> clear">
        +     <label for="billing_address_1" class="name">Address Line 1: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="billing_address_1" name="billing_address_1" value="<%if billing_address_1%><%billing_address_1%><%endif%>" class="text" />
        ++      <input type="text" id="billing_address_1" name="billing_address_1" value="<%if billing_address_1%><%escape_html billing_address_1%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row<%if billing_address_2_error%> invalid<%endif%> clear">
        +     <label for="billing_address_2" class="name">Address Line 2:</label>
        +     <div class="value">
        +-      <input type="text" id="billing_address_2" name="billing_address_2" value="<%if billing_address_2%><%billing_address_2%><%endif%>" class="text" />
        ++      <input type="text" id="billing_address_2" name="billing_address_2" value="<%if billing_address_2%><%escape_html billing_address_2%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required<%if billing_city_error%> invalid<%endif%> clear">
        +Index: luna/payment_method.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_method.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/payment_method.html    24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/payment_method.html    18 Apr 2005 21:39:36 -0000      1.12
        +@@ -48,14 +48,14 @@
        +   <input type="hidden" name="do" value="payment_form" />
        +   <input type="hidden" name="last_step" value="method" />
        +   <input type="hidden" name="last_page" value="payment_method" />
        +-  <input type="hidden" name="cat_id" value="<%cat_id%>" />
        +-  <input type="hidden" name="link_id" value="<%link_id%>" />
        +-  <input type="hidden" name="payment_term" value="<%payment_term%>" />
        ++  <input type="hidden" name="cat_id" value="<%escape_html cat_id%>" />
        ++  <input type="hidden" name="link_id" value="<%escape_html link_id%>" />
        ++  <input type="hidden" name="payment_term" value="<%escape_html payment_term%>" />
        +   <%if modify%><input type="hidden" name="modify" value="1" /><%endif%>
        +
        + <%~if direct_methods_used or remote_methods_used%>
        + <%~loop payment_methods%>
        +-  <input type="radio" id="payment_method-<%if payment_direct%>direct<%else%>remote<%endif%>_<%payment_method%>" name="payment_method" value="<%if payment_direct%>direct<%else%>remote<%endif%>_<%payment_method%>" class="radio" />
        ++  <input type="radio" id="payment_method-<%if payment_direct%>direct<%else%>remote<%endif%>_<%payment_method%>" name="payment_method" value="<%if payment_direct%>direct<%else%>remote<%endif%>_<%escape_html payment_method%>" class="radio" />
        +   <label for="payment_method-<%if payment_direct%>direct<%else%>remote<%endif%>_<%payment_method%>"><%if payment_name%><%payment_name%><%else%><%payment_method%><%endif%></label><br />
        +   <blockquote><%loop payment_types%><%name%><%unless last%>, <%endunless%><%endloop%></blockquote>
        + <%~endloop%>
        +Index: luna/payment_paypal_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_paypal_include.html,v
        +retrieving revision 1.4
        +retrieving revision 1.5
        +diff -u -b -r1.4 -r1.5
        +--- luna/payment_paypal_include.html    4 Mar 2005 21:35:27 -0000       1.4
        ++++ luna/payment_paypal_include.html    18 Apr 2005 21:39:36 -0000      1.5
        +@@ -1,26 +1,26 @@
        + <form action="https://www.<%if sandbox%>sandbox.<%endif%>paypal.com/cgi-bin/webscr" method="post">
        +-  <input type="hidden" name="business" value="<%if to_email%><%to_email%><%else%><%business_email%><%endif%>" />
        +-  <input type="hidden" name="currency_code" value="<%currency%>" />
        ++  <input type="hidden" name="business" value="<%if to_email%><%escape_html to_email%><%else%><%escape_html business_email%><%endif%>" />
        ++  <input type="hidden" name="currency_code" value="<%escape_html currency%>" />
        +   <input type="hidden" name="return" value="<%config.db_cgi_url%>/add.cgi" />
        +   <input type="hidden" name="custom" value="do;process_payment=1;payment_success=1<%loop config.dynamic_preserve%><%if in.$loop_value%>;<%loop_value%>=<%in.$loop_value%><%endloop%>" />
        +   <input type="hidden" name="cancel_return" value="<%config.db_cgi_url%>/add.cgi" />
        +   <input type="hidden" name="rm" value="2" />
        +-  <%if notify_url%><input type="hidden" name="notify_url" value="<%notify_url%>" /><%endif%>
        +-  <%if pp_image_url%><input type="hidden" name="image_url" value="<%pp_image_url%>" /><%endif%>
        +-  <%if note and payment_type != 2 %><input type="hidden" name="cn" value="<%note%>" /><%else%><input type="hidden" name="no_note" value="1" /><%endif%>
        ++  <%if notify_url%><input type="hidden" name="notify_url" value="<%escape_html notify_url%>" /><%endif%>
        ++  <%if pp_image_url%><input type="hidden" name="image_url" value="<%escape_html pp_image_url%>" /><%endif%>
        ++  <%if note and payment_type != 2 %><input type="hidden" name="cn" value="<%escape_html note%>" /><%else%><input type="hidden" name="no_note" value="1" /><%endif%>
        +   <%if color eq 'black'%><input type="hidden" name="cs" value="1" /><%endif%>
        +   <input type="hidden" name="cmd" value="_xclick<%if payment_type == 2%>-subscriptions<%endif%>" />
        + <%~if payment_type == 2%>
        +-  <input type="hidden" name="a3" value="<%payment_amount%>" />
        +-  <input type="hidden" name="p3" value="<%payment_term_num%>" />
        ++  <input type="hidden" name="a3" value="<%escape_html payment_amount%>" />
        ++  <input type="hidden" name="p3" value="<%escape_html payment_term_num%>" />
        +   <input type="hidden" name="t3" value="<%if payment_term_u istarts 'd'%>D<%elsif payment_term_u istarts 'w'%>W<%elsif payment_term_u istarts 'm'%>M<%elsif payment_term_u istarts 'y'%>Y<%endif%>" />
        +   <input type="hidden" name="src" value="1" />
        +   <input type="hidden" name="sra" value="1" />
        + <%~else%>
        +-  <input type="hidden" name="amount" value="<%payment_amount%>" />
        ++  <input type="hidden" name="amount" value="<%escape_html payment_amount%>" />
        + <%~endif%>
        +-  <input type="hidden" name="invoice" value="<%unique_id%>" />
        +-  <input type="hidden" name="item_name" value="<%site_title%> link submission (<%ifnot payment_term_num%>Lifetime<%else%><%payment_term_num%> <%payment_term_unit%><%endif%><%if payment_type == 2%>, recurring<%endif%>)" />
        ++  <input type="hidden" name="invoice" value="<%escape_html unique_id%>" />
        ++  <input type="hidden" name="item_name" value="<%escape_html site_title%> link submission (<%ifnot payment_term_num%>Lifetime<%else%><%escape_html payment_term_num%> <%escape_html payment_term_unit%><%endif%><%if payment_type == 2%>, recurring<%endif%>)" />
        +   <input type="hidden" name="no_shipping" value="1" />
        +-  <input type="image" name="submit" src="<%if button_custom%><%button_custom%><%else%>https://www.paypal.com/images/<%button%><%endif%>" title="Make payments with PayPal - it's fast, free and secure!" class="image" />
        ++  <input type="image" name="submit" src="<%if button_custom%><%escape_html button_custom%><%else%>https://www.paypal.com/images/<%button%><%endif%>" title="Make payments with PayPal - it's fast, free and secure!" class="image" />
        + </form>
        +Index: luna/payment_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_success.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/payment_success.html   24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/payment_success.html   14 Apr 2005 03:16:50 -0000      1.12
        +@@ -21,7 +21,10 @@
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment Confirmation</h2>
        +
        +-Your payment has been approved.  You will be redirected to the main page shortly.  If this does not happen, click <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++<p>
        ++  Your payment has been approved.  You will be redirected to the main page shortly.
        ++  If this does not happen, click <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++</p>
        +
        +             </div>
        +           </div>
        +Index: luna/payment_worldpay_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_worldpay_include.html,v
        +retrieving revision 1.3
        +retrieving revision 1.4
        +diff -u -b -r1.3 -r1.4
        +--- luna/payment_worldpay_include.html  15 Feb 2005 21:06:14 -0000      1.3
        ++++ luna/payment_worldpay_include.html  18 Apr 2005 21:39:36 -0000      1.4
        +@@ -1,19 +1,19 @@
        + <form action="https://select.worldpay.com/wcc/purchase" method="post">
        +-  <input type="hidden" name="instId" value="<%installation_id%>" />
        +-  <%if test_mode%><input type="hidden" name="testMode" value="<%test_mode%>" /><%endif%>
        +-  <input type="hidden" name="currency" value="<%currency%>" />
        +-  <input type="hidden" name="amount" value="<%payment_amount%>" />
        ++  <input type="hidden" name="instId" value="<%escape_html installation_id%>" />
        ++  <%if test_mode%><input type="hidden" name="testMode" value="<%escape_html test_mode%>" /><%endif%>
        ++  <input type="hidden" name="currency" value="<%escape_html currency%>" />
        ++  <input type="hidden" name="amount" value="<%escape_html payment_amount%>" />
        + <%~if payment_type = 2%>
        +   <input type="hidden" name="futurePayType" value="regular" />
        +   <input type="hidden" name="option" value="0" />
        +-  <input type="hidden" name="normalAmount" value="<%payment_amount%>" />
        ++  <input type="hidden" name="normalAmount" value="<%escape_html payment_amount%>" />
        +   <input type="hidden" name="startDelayUnit" value="<%if payment_term_u istarts 'd'%>1<%elsif payment_term_u istarts 'w'%>2<%elsif payment_term_u istarts 'm'%>3<%elsif payment_term_u istarts 'y'%>4<%endif%>" />
        +-  <input type="hidden" name="startDelayMult" value="<%payment_term_num%>" />
        ++  <input type="hidden" name="startDelayMult" value="<%escape_html payment_term_num%>" />
        +   <input type="hidden" name="intervalUnit" value="<%if payment_term_u istarts 'd'%>1<%elsif payment_term_u istarts 'w'%>2<%elsif payment_term_u istarts 'm'%>3<%elsif payment_term_u istarts 'y'%>4<%endif%>" />
        +-  <input type="hidden" name="intervalMult" value="<%payment_term_num%>" />
        ++  <input type="hidden" name="intervalMult" value="<%escape_html payment_term_num%>" />
        + <%~endif%>
        +-  <input type="hidden" name="cartId" value="<%unique_id%>" />
        +-  <input type="hidden" name="desc" value="<%site_title%> link submission (<%ifnot payment_term_num%>Lifetime<%else%><%payment_term_num%> <%payment_term_unit%><%endif%><%if payment_type == 2%>, recurring<%endif%>)" />
        ++  <input type="hidden" name="cartId" value="<%escape_html unique_id%>" />
        ++  <input type="hidden" name="desc" value="<%escape_html site_title%> link submission (<%ifnot payment_term_num%>Lifetime<%else%><%escape_html payment_term_num%> <%escape_html payment_term_unit%><%endif%><%if payment_type == 2%>, recurring<%endif%>)" />
        +   <input type="hidden" name="signatureFields" value="amount:currency:cartId" />
        +   <input type="hidden" name="signature" value="<%GT::Payment::Remote::WorldPay::md5_signature($md5_password, $payment_amount, $currency, $unique_id)%>" />
        +   <input type="submit" value="Make Payment" class="submit" />
        +Index: luna/rate.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -b -r1.11 -r1.12
        +--- luna/rate.html      24 Mar 2005 08:58:29 -0000      1.11
        ++++ luna/rate.html      18 Apr 2005 21:39:36 -0000      1.12
        +@@ -25,7 +25,7 @@
        + </p>
        +
        + <form action="<%config.db_cgi_url%>/rate.cgi" method="post">
        +-  <input type="hidden" name="ID" value="<%ID%>" />
        ++  <input type="hidden" name="ID" value="<%escape_html ID%>" />
        +
        +   <div class="row required clear">
        +     <label for="rate" class="name">Link Rating:</label>
        +Index: luna/review_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add.html,v
        +retrieving revision 1.15
        +retrieving revision 1.17
        +diff -u -b -r1.15 -r1.17
        +--- luna/review_add.html        24 Mar 2005 08:58:29 -0000      1.15
        ++++ luna/review_add.html        18 Apr 2005 21:39:36 -0000      1.17
        +@@ -27,7 +27,7 @@
        + </p>
        +
        + <form action="<%config.db_cgi_url%>/review.cgi" method="post">
        +-  <%if ID%><input type="hidden" name="ID" value="<%ID%>" /><%endif%>
        ++  <%if ID%><input type="hidden" name="ID" value="<%escape_html ID%>" /><%endif%>
        +   <input type="hidden" name="add_this_review" value="1" />
        +   <div class="row required clear">
        +     <label class="name">Your Rating: <span>*</span></label>
        +@@ -42,32 +42,32 @@
        +   <div class="row required clear">
        +     <label for="Review_Subject" class="name">Subject: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Review_Subject" name="Review_Subject" value="<%if Review_Subject%><%Review_Subject%><%endif%>" class="text" />
        ++      <input type="text" id="Review_Subject" name="Review_Subject" value="<%if Review_Subject%><%escape_html Review_Subject%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +     <label for="Review_ByLine" class="name">By Line:</label>
        +     <div class="value">
        +-      <input type="text" id="Review_ByLine" name="Review_ByLine" value="<%if Review_ByLine%><%Review_ByLine%><%endif%>" class="text" />
        ++      <input type="text" id="Review_ByLine" name="Review_ByLine" value="<%if Review_ByLine%><%escape_html Review_ByLine%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required clear">
        +     <label for="Review_Contents" class="name">Your Review: <span>*</span></label>
        +     <div class="value">
        +-      <textarea id="Review_Contents" name="Review_Contents" rows="3" cols="42"><%if Review_Contents%><%Review_Contents%><%endif%></textarea>
        ++      <textarea id="Review_Contents" name="Review_Contents" rows="3" cols="42"><%if Review_Contents%><%escape_html Review_Contents%><%endif%></textarea>
        +     </div>
        +   </div>
        +-<%~if anonymous%>
        ++<%~if not config.user_review_required and not user.Username%>
        +   <div class="row required clear">
        +     <label for="Review_GuestName" class="name">Your Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Review_GuestName" name="Review_GuestName" value="<%if Review_GuestName%><%Review_GuestName%><%endif%>" class="text" />
        ++      <input type="text" id="Review_GuestName" name="Review_GuestName" value="<%if Review_GuestName%><%escape_html Review_GuestName%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required clear">
        +     <label for="Review_GuestEmail" class="name">Your E-mail: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Review_GuestEmail" name="Review_GuestEmail" value="<%if Review_GuestEmail%><%Review_GuestEmail%><%endif%>" class="text" />
        ++      <input type="text" id="Review_GuestEmail" name="Review_GuestEmail" value="<%if Review_GuestEmail%><%escape_html Review_GuestEmail%><%endif%>" class="text" />
        +     </div>
        +   </div>
        + <%~endif%>
        +Index: luna/review_add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add_success.html,v
        +retrieving revision 1.12
        +retrieving revision 1.14
        +diff -u -b -r1.12 -r1.14
        +--- luna/review_add_success.html        24 Mar 2005 08:58:29 -0000      1.12
        ++++ luna/review_add_success.html        15 Apr 2005 00:07:25 -0000      1.14
        +@@ -40,7 +40,7 @@
        +   <label class="name">Review:</label>
        +   <div class="value wrappedtext"><%Review_Contents%></div>
        + </div>
        +-<%~ifnot config.user_review_required%>
        ++<%~if not config.user_review_required and not user.Username%>
        + <div class="row clear">
        +   <label class="name">Name:</label>
        +   <div class="value wrappedtext"><%Review_GuestName%></div>
        +@@ -52,7 +52,11 @@
        + <%~endif%>
        +
        + <p>
        ++<%~if config.review_auto_validate%>
        ++  Thank you! Your review has been added.
        ++<%~else%>
        +   Thank you! We will send you an e-mail once your review has been validated.
        ++<%~endif%>
        + </p>
        +
        +             </div>
        +Index: luna/review_added.eml
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_added.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -b -r1.6 -r1.7
        +--- luna/review_added.eml       15 Mar 2005 20:13:12 -0000      1.6
        ++++ luna/review_added.eml       15 Apr 2005 00:07:25 -0000      1.7
        +@@ -12,7 +12,7 @@
        +     By Line: <%Review_ByLine%>
        +     Date: <%Review_Date%>
        +     Contents: <%Review_Contents%>
        +-<%~if anonymous%>
        ++<%~if not config.user_review_required and not user.Username%>
        +     Name: <%Review_GuestName%>
        +     E-mail: <%Review_GuestEmail%>
        + <%~endif%>
        +Index: luna/review_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -b -r1.13 -r1.14
        +--- luna/review_edit.html       24 Mar 2005 08:58:29 -0000      1.13
        ++++ luna/review_edit.html       18 Apr 2005 21:39:36 -0000      1.14
        +@@ -32,14 +32,14 @@
        +
        + <form action="<%config.db_cgi_url%>/review.cgi" method="post">
        +   <input type="hidden" name="edit_review" value="1" />
        +-  <input type="hidden" name="ID" value="<%ID%>" />
        ++  <input type="hidden" name="ID" value="<%escape_html ID%>" />
        + <%~if confirm%>
        +   <div class="formsubmit">
        +     <input type="submit" name="confirmed" value="Continue" class="submit" />
        +     <input type="submit" name="cancelled" value="Cancel" class="submit" />
        +   </div>
        + <%~else%>
        +-  <input type="hidden" name="ReviewID" value="<%if ReviewID%><%ReviewID%><%endif%>" />
        ++  <input type="hidden" name="ReviewID" value="<%if ReviewID%><%escape_html ReviewID%><%endif%>" />
        +
        +   <div class="row required clear">
        +     <label class="name">Your Rating: <span>*</span></label>
        +@@ -54,19 +54,19 @@
        +   <div class="row required clear">
        +     <label for="Review_Subject" class="name">Subject: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Review_Subject" name="Review_Subject" value="<%if Review_Subject%><%Review_Subject%><%endif%>" class="text" />
        ++      <input type="text" id="Review_Subject" name="Review_Subject" value="<%if Review_Subject%><%escape_html Review_Subject%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +     <label for="Review_ByLine" class="name">By Line:</label>
        +     <div class="value">
        +-      <input type="text" id="Review_ByLine" name="Review_ByLine" value="<%if Review_ByLine%><%Review_ByLine%><%endif%>" class="text" />
        ++      <input type="text" id="Review_ByLine" name="Review_ByLine" value="<%if Review_ByLine%><%escape_html Review_ByLine%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required clear">
        +     <label for="Review_Contents" class="name">Your Review: <span>*</span></label>
        +     <div class="value">
        +-      <textarea id="Review_Contents" name="Review_Contents" rows="3" cols="42"><%if Review_Contents%><%Review_Contents%><%endif%></textarea>
        ++      <textarea id="Review_Contents" name="Review_Contents" rows="3" cols="42"><%if Review_Contents%><%escape_html Review_Contents%><%endif%></textarea>
        +     </div>
        +   </div>
        +   <div class="formsubmit">
        +Index: luna/review_edit_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit_success.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -b -r1.9 -r1.10
        +--- luna/review_edit_success.html       24 Mar 2005 08:58:29 -0000      1.9
        ++++ luna/review_edit_success.html       14 Apr 2005 07:37:09 -0000      1.10
        +@@ -20,7 +20,9 @@
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Review Updated</h2>
        +
        +-We have received the following review:
        ++<p>
        ++  We have received the following review:
        ++</p>
        +
        + <div class="row clear">
        +   <label class="name">Rating:</label>
        +@@ -39,7 +41,13 @@
        +   <div class="value wrappedtext"><%Review_Contents%></div>
        + </div>
        +
        +-Thank you! We will send you an e-mail once your review has been validated.
        ++<p>
        ++<%~if config.review_auto_validate%>
        ++  Your review has been modified.
        ++<%~else%>
        ++  Thank you! We will send you an e-mail once your review has been validated.
        ++<%~endif%>
        ++</p>
        +
        +             </div>
        +           </div>
        +Index: luna/review_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_include.html,v
        +retrieving revision 1.11
        +retrieving revision 1.13
        +diff -u -b -r1.11 -r1.13
        +--- luna/review_include.html    22 Mar 2005 02:01:36 -0000      1.11
        ++++ luna/review_include.html    18 Apr 2005 21:39:36 -0000      1.13
        +@@ -6,7 +6,7 @@
        +   <%~set ID = ''%>
        + <%~endif%>
        +   <h4 class="reviewsubject">
        +-    <%Review_Subject%><%if Review_Owner eq $user.Username%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;confirmed=1">edit</a>)</span><%endif%>
        ++    <%Review_Subject%><%if Review_Owner eq $user.Username and config.review_allow_modify%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;confirmed=1">edit</a>)</span><%endif%>
        +     <img src="<%Links::Utils::image_url("stars-5-${Review_Rating}.gif")%>" alt="<%Review_Rating%> out of 5 stars" title="<%Review_Rating%> out of 5 stars" />
        +     <%if Review_IsNew%><span class="new-item"><span>new</span></span><%endif%>
        +   </h4>
        +@@ -26,11 +26,11 @@
        +   <div class="reviewhelpful clear">
        +     <span><%if Num%><%Review_WasHelpful%> of <%Num%> people found this review helpful<%endif%></span>
        +     <form action="<%config.db_cgi_url%>/review.cgi">
        +-      <%if nh and nh != 1%><input type="hidden" name="nh" value="<%nh%>" /><%endif%>
        ++      <%if nh and nh != 1%><input type="hidden" name="nh" value="<%escape_html nh%>" /><%endif%>
        +       <input type="hidden" name="helpful" value="1" />
        +-      <%if ID%><input type="hidden" name="ID" value="<%ID%>" /><%endif%>
        +-      <%if username%><input type="hidden" name="username" value="<%username%>" /><%endif%>
        +-      <%if ReviewID%><input type="hidden" name="ReviewID" value="<%ReviewID%>" /><%endif%>
        ++      <%if ID%><input type="hidden" name="ID" value="<%escape_html ID%>" /><%endif%>
        ++      <%if username%><input type="hidden" name="username" value="<%escape_html username%>" /><%endif%>
        ++      <%if ReviewID%><input type="hidden" name="ReviewID" value="<%escape_html ReviewID%>" /><%endif%>
        +       <span>
        +       <%~if last_helpful%>
        +         Thanks for the feedback.
        +Index: luna/signup_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/signup_form.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -b -r1.13 -r1.14
        +--- luna/signup_form.html       24 Mar 2005 08:58:29 -0000      1.13
        ++++ luna/signup_form.html       18 Apr 2005 21:39:36 -0000      1.14
        +@@ -28,7 +28,7 @@
        +   <div class="row required clear">
        +     <label for="Username" class="name">Username: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Username" name="Username" value="<%if Username%><%Username%><%endif%>" class="text" />
        ++      <input type="text" id="Username" name="Username" value="<%if Username%><%escape_html Username%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row required clear">
        +@@ -40,7 +40,7 @@
        +   <div class="row required clear">
        +     <label for="Email" class="name">E-mail: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="Email" name="Email" value="<%if Email%><%Email%><%endif%>" class="text" />
        ++      <input type="text" id="Email" name="Email" value="<%if Email%><%escape_html Email%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="formsubmit">
        +Index: luna/subcategory.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/subcategory.html,v
        +retrieving revision 1.2
        +retrieving revision 1.3
        +diff -u -b -r1.2 -r1.3
        +--- luna/subcategory.html       1 Mar 2005 01:14:13 -0000       1.2
        ++++ luna/subcategory.html       13 Apr 2005 02:06:35 -0000      1.3
        +@@ -1,2 +1,2 @@
        +-<dt><a href="<%URL%>"><%Name%><%if Related%>@<%endif%></a> (<%Number_of_Links%>)<%if Has_New_Links eq 'Yes'%> <span class="new-item"><span>new</span></span><%endif%><%if Has_Changed_Links eq 'Yes'%> <span class="updated-item">updated</span></span><%endif%></dt>
        ++<dt><a href="<%URL%>"><%Name%><%if Related%>@<%endif%></a> (<%Number_of_Links%>)<%if Has_New_Links eq 'Yes'%> <span class="new-item"><span>new</span></span><%endif%><%if Has_Changed_Links eq 'Yes'%> <span class="updated-item"><span>updated</span></span><%endif%></dt>
        + <%if Description%><dd><%Description%></dd><%endif%>
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.css.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.css.diff.html new file mode 100644 index 0000000..316ec5b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.css.diff.html @@ -0,0 +1,36 @@ + + +Gossamer Links 3.0.1 -> 3.0.2 "luna" template set CSS diff + + + +
        +Index: luna_core.css
        +===================================================================
        +RCS file: /glinks/html/static/luna/luna_core.css,v
        +retrieving revision 1.26
        +retrieving revision 1.28
        +diff -u -r1.26 -r1.28
        +--- luna_core.css       7 Apr 2005 07:49:39 -0000       1.26
        ++++ luna_core.css       18 May 2005 23:26:59 -0000      1.28
        +@@ -458,7 +458,7 @@
        +   font-weight: normal;
        +   font-size: 9px;
        +   color: #ffffff;
        +-  vertical-align: top;
        ++  vertical-align: text-top;
        + }
        + .new-item {
        +   background-color: #8c3030;
        +@@ -560,7 +560,7 @@
        + }
        + /* hack for ie 5.5 text/textarea resizing */
        + .row .value input.text, .row .value input.password, .row .value textarea {
        +-  width: expression(this.parentNode.offsetWidth * 0.74);
        ++  width: expression(this.parentNode.offsetWidth * 0.74 + 'px');
        + }
        + /* the previous style causes problems with long sidebars in ie6 */
        + .row .value input.text, .row .value input.password, .row .value textarea {
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.diff.html new file mode 100644 index 0000000..f494d3d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.1-3.0.2.diff.html @@ -0,0 +1,901 @@ + + +Gossamer Links 3.0.1 -> 3.0.2 "luna" template set diff + + + +
        +Index: add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/add.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- add.html    24 Mar 2005 08:58:29 -0000      1.9
        ++++ add.html    11 May 2005 22:35:47 -0000      1.10
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/add_success.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- add_success.html    14 Apr 2005 03:07:05 -0000      1.12
        ++++ add_success.html    11 May 2005 22:35:47 -0000      1.13
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_folder_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_add.html,v
        +retrieving revision 1.12
        +retrieving revision 1.14
        +diff -u -r1.12 -r1.14
        +--- bookmark_folder_add.html    18 Apr 2005 21:39:36 -0000      1.12
        ++++ bookmark_folder_add.html    11 May 2005 22:35:47 -0000      1.14
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +@@ -26,7 +26,7 @@
        +   <div class="row required clear">
        +     <label for="my_folder_name" class="name">Name: <span>*</span></label>
        +     <div class="value">
        +-      <input type="text" id="my_folder_name"  name="my_folder_name" value="<%if my_folder_name%><%escape_html my_folder_name%><%endif%>" class="text" />
        ++      <input type="text" id="my_folder_name" name="my_folder_name" value="<%if my_folder_name%><%escape_html my_folder_name%><%endif%>" class="text" />
        +     </div>
        +   </div>
        +   <div class="row clear">
        +Index: bookmark_folder_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_edit.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- bookmark_folder_edit.html   18 Apr 2005 21:39:36 -0000      1.12
        ++++ bookmark_folder_edit.html   11 May 2005 22:35:47 -0000      1.13
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_folder_view.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_view.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- bookmark_folder_view.html   24 Mar 2005 08:58:29 -0000      1.14
        ++++ bookmark_folder_view.html   11 May 2005 22:35:47 -0000      1.15
        +@@ -16,7 +16,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_link_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_add.html,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -r1.16 -r1.17
        +--- bookmark_link_add.html      18 Apr 2005 21:39:36 -0000      1.16
        ++++ bookmark_link_add.html      11 May 2005 22:35:47 -0000      1.17
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_link_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_edit.html,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -r1.16 -r1.17
        +--- bookmark_link_edit.html     18 Apr 2005 21:39:36 -0000      1.16
        ++++ bookmark_link_edit.html     11 May 2005 22:35:47 -0000      1.17
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_list.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- bookmark_list.html  18 Apr 2005 21:39:36 -0000      1.13
        ++++ bookmark_list.html  11 May 2005 22:35:47 -0000      1.14
        +@@ -16,7 +16,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_preferences.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_preferences.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- bookmark_preferences.html   18 Apr 2005 21:39:36 -0000      1.13
        ++++ bookmark_preferences.html   11 May 2005 22:35:47 -0000      1.14
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: bookmark_users.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_users.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- bookmark_users.html 24 Mar 2005 08:58:29 -0000      1.11
        ++++ bookmark_users.html 11 May 2005 22:35:47 -0000      1.12
        +@@ -16,7 +16,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: category.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.26
        +retrieving revision 1.27
        +diff -u -r1.26 -r1.27
        +--- category.html       13 Apr 2005 19:39:01 -0000      1.26
        ++++ category.html       11 May 2005 22:35:47 -0000      1.27
        +@@ -17,7 +17,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: cool.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/cool.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- cool.html   24 Mar 2005 08:58:29 -0000      1.13
        ++++ cool.html   11 May 2005 22:35:47 -0000      1.14
        +@@ -15,7 +15,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: detailed.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/detailed.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- detailed.html       24 Mar 2005 08:58:29 -0000      1.15
        ++++ detailed.html       11 May 2005 22:35:47 -0000      1.16
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: error.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/error.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- error.html  24 Mar 2005 08:58:29 -0000      1.10
        ++++ error.html  11 May 2005 22:35:47 -0000      1.11
        +@@ -11,7 +11,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: home.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/home.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- home.html   29 Mar 2005 09:51:43 -0000      1.14
        ++++ home.html   11 May 2005 22:35:47 -0000      1.15
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: include_contentfooter.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_contentfooter.html,v
        +retrieving revision 1.1
        +retrieving revision 1.3
        +diff -u -r1.1 -r1.3
        +--- include_contentfooter.html  28 Jan 2005 23:20:13 -0000      1.1
        ++++ include_contentfooter.html  7 May 2005 22:26:31 -0000       1.3
        +@@ -1,2 +1,4 @@
        +-<div id="contentfooter">
        ++<%--
        ++<div id="contentfooter" class="clear">
        + </div>
        ++--%>
        +Index: language.txt
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/language.txt,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- language.txt        15 Apr 2005 03:32:10 -0000      1.17
        ++++ language.txt        12 May 2005 20:51:55 -0000      1.18
        +@@ -160,11 +160,13 @@
        +        'SUBSCRIBE_NOTSUB' => 'You are not subscribed to this mailing list.',
        +        'SUBSCRIBE_SUCCESS' => 'You have successfully subscribed to the mailing list.',
        +        'SUBSCRIBE_UNSUBSUCCESS' => 'You have successfully unsubscribed from the mailing list.',
        ++       'USER_AUTHERROR' => 'Authentication error: %s',
        +        'USER_BADLOGIN' => 'Invalid username/password.',
        +        'USER_EMAILTAKEN' => 'The e-mail address you entered is already taken.',
        +        'USER_INVALIDEMAIL' => 'Invalid e-mail address: \'%s\'',
        +        'USER_INVALIDNAME' => 'Invalid name: \'%s\'',
        +        'USER_INVALIDSIGNUP' => 'Please fill out all fields completely.',
        ++       'USER_INVALIDUSERNAME' => 'Invalid format for username: %s',
        +        'USER_INVALIDVAL' => 'Invalid validation code.',
        +        'USER_LOGOUT' => 'You have been successfully logged out.',
        +        'USER_NAMETAKEN' => 'The username you requested is already taken.',
        +Index: link_expiry_notify.eml
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/link_expiry_notify.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -r1.6 -r1.7
        +--- link_expiry_notify.eml      14 Mar 2005 23:13:40 -0000      1.6
        ++++ link_expiry_notify.eml      21 Apr 2005 19:49:17 -0000      1.7
        +@@ -8,7 +8,7 @@
        +
        + <%loop expiry_links~%>
        +     <%Title%>
        +-        Expiry Date: <%ExpiryDate%>.
        ++        Expiry Date: <%ExpiryDate%>
        +         Renewal Payment: <%renewal_url%>
        + <%endloop%>
        + Please make a payment as soon as possible or contact us for more information.
        +Index: login.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- login.html  18 Apr 2005 21:39:36 -0000      1.15
        ++++ login.html  11 May 2005 22:35:47 -0000      1.16
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: login_email.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login_email.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- login_email.html    18 Apr 2005 21:39:36 -0000      1.11
        ++++ login_email.html    11 May 2005 22:35:47 -0000      1.12
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: login_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login_success.html,v
        +retrieving revision 1.8
        +retrieving revision 1.10
        +diff -u -r1.8 -r1.10
        +--- login_success.html  24 Mar 2005 08:58:29 -0000      1.8
        ++++ login_success.html  11 May 2005 22:35:47 -0000      1.10
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +@@ -24,6 +24,12 @@
        +   You have been successfully logged into <%site_title%>.
        + </p>
        +
        ++<%if not d and Links::Utils::is_editor%>
        ++<p>
        ++  Enter the <a href="<%config.db_cgi_url%>/browser.cgi">editor system</a>.
        ++</p>
        ++<%endif%>
        ++
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        +Index: modify.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- modify.html 18 Apr 2005 21:39:36 -0000      1.10
        ++++ modify.html 11 May 2005 22:35:47 -0000      1.11
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: modify_select.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify_select.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- modify_select.html  18 Apr 2005 21:39:36 -0000      1.13
        ++++ modify_select.html  11 May 2005 22:35:47 -0000      1.14
        +@@ -15,7 +15,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: modify_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify_success.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- modify_success.html 24 Mar 2005 08:58:29 -0000      1.11
        ++++ modify_success.html 11 May 2005 22:35:47 -0000      1.12
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: new.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/new.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- new.html    24 Mar 2005 08:58:29 -0000      1.12
        ++++ new.html    11 May 2005 22:35:47 -0000      1.13
        +@@ -15,7 +15,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: newsletter.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter.html,v
        +retrieving revision 1.8
        +retrieving revision 1.9
        +diff -u -r1.8 -r1.9
        +--- newsletter.html     24 Mar 2005 08:58:29 -0000      1.8
        ++++ newsletter.html     11 May 2005 22:35:47 -0000      1.9
        +@@ -13,7 +13,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: newsletter_browse.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_browse.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- newsletter_browse.html      18 Apr 2005 21:39:36 -0000      1.14
        ++++ newsletter_browse.html      11 May 2005 22:35:47 -0000      1.15
        +@@ -64,7 +64,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: newsletter_global.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_global.html,v
        +retrieving revision 1.8
        +retrieving revision 1.9
        +diff -u -r1.8 -r1.9
        +--- newsletter_global.html      24 Mar 2005 08:58:29 -0000      1.8
        ++++ newsletter_global.html      11 May 2005 22:35:47 -0000      1.9
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: newsletter_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_list.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- newsletter_list.html        18 Apr 2005 21:39:36 -0000      1.14
        ++++ newsletter_list.html        11 May 2005 22:35:47 -0000      1.15
        +@@ -16,7 +16,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: payment.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- payment.html        18 Apr 2005 21:39:36 -0000      1.11
        ++++ payment.html        11 May 2005 22:35:47 -0000      1.12
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: payment_direct.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_direct.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- payment_direct.html 14 Apr 2005 03:16:50 -0000      1.12
        ++++ payment_direct.html 11 May 2005 22:35:47 -0000      1.13
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: payment_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_form.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- payment_form.html   24 Mar 2005 08:58:29 -0000      1.9
        ++++ payment_form.html   11 May 2005 22:35:47 -0000      1.10
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: payment_method.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_method.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- payment_method.html 18 Apr 2005 21:39:36 -0000      1.12
        ++++ payment_method.html 11 May 2005 22:35:47 -0000      1.13
        +@@ -11,7 +11,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: payment_paypal_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_paypal_include.html,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- payment_paypal_include.html 18 Apr 2005 21:39:36 -0000      1.5
        ++++ payment_paypal_include.html 21 Apr 2005 19:49:06 -0000      1.6
        +@@ -22,5 +22,5 @@
        +   <input type="hidden" name="invoice" value="<%escape_html unique_id%>" />
        +   <input type="hidden" name="item_name" value="<%escape_html site_title%> link submission (<%ifnot payment_term_num%>Lifetime<%else%><%escape_html payment_term_num%> <%escape_html payment_term_unit%><%endif%><%if payment_type == 2%>, recurring<%endif%>)" />
        +   <input type="hidden" name="no_shipping" value="1" />
        +-  <input type="image" name="submit" src="<%if button_custom%><%escape_html button_custom%><%else%>https://www.paypal.com/images/<%button%><%endif%>" title="Make payments with PayPal - it's fast, free and secure!" class="image" />
        ++  <input type="image" name="submit" src="<%if button_custom%><%escape_html button_custom%><%else%>https://www.paypal.com/images/<%escape_html button%><%endif%>" title="Make payments with PayPal - it's fast, free and secure!" class="image" />
        + </form>
        +Index: payment_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_success.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- payment_success.html        14 Apr 2005 03:16:50 -0000      1.12
        ++++ payment_success.html        11 May 2005 22:35:47 -0000      1.13
        +@@ -10,7 +10,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: rate.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- rate.html   18 Apr 2005 21:39:36 -0000      1.12
        ++++ rate.html   11 May 2005 22:35:47 -0000      1.13
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: rate_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate_success.html,v
        +retrieving revision 1.8
        +retrieving revision 1.9
        +diff -u -r1.8 -r1.9
        +--- rate_success.html   24 Mar 2005 08:58:29 -0000      1.8
        ++++ rate_success.html   11 May 2005 22:35:47 -0000      1.9
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: rate_top.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate_top.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- rate_top.html       24 Mar 2005 08:58:29 -0000      1.11
        ++++ rate_top.html       11 May 2005 22:35:47 -0000      1.12
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: review_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- review_add.html     18 Apr 2005 21:39:36 -0000      1.17
        ++++ review_add.html     11 May 2005 22:35:47 -0000      1.18
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: review_add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add_success.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- review_add_success.html     15 Apr 2005 00:07:25 -0000      1.14
        ++++ review_add_success.html     11 May 2005 22:35:47 -0000      1.15
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: review_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- review_edit.html    18 Apr 2005 21:39:36 -0000      1.14
        ++++ review_edit.html    11 May 2005 22:35:47 -0000      1.15
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: review_edit_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit_success.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- review_edit_success.html    14 Apr 2005 07:37:09 -0000      1.10
        ++++ review_edit_success.html    11 May 2005 22:35:47 -0000      1.11
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: review_search_results.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_search_results.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- review_search_results.html  24 Mar 2005 08:58:29 -0000      1.13
        ++++ review_search_results.html  11 May 2005 22:35:47 -0000      1.14
        +@@ -15,7 +15,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: search.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/search.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- search.html 24 Mar 2005 08:58:29 -0000      1.12
        ++++ search.html 11 May 2005 22:35:47 -0000      1.13
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: search_results.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/search_results.html,v
        +retrieving revision 1.15
        +retrieving revision 1.17
        +diff -u -r1.15 -r1.17
        +--- search_results.html 24 Mar 2005 08:58:29 -0000      1.15
        ++++ search_results.html 11 May 2005 22:35:47 -0000      1.17
        +@@ -15,7 +15,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +@@ -27,7 +27,7 @@
        + <h2>Search Results</h2>
        +
        + <p>
        +-  Your search for <%if highlight%><%Links::Tools::highlight($query, $query)%><%else%><strong><%query%></strong><%endif%> returned <strong><%cat_hits%></strong> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <strong><%link_hits%></strong> link<%if link_hits != 1%>s<%endif%>
        ++  Your search<%if query%> for <%if highlight%><%Links::Tools::highlight($query, $query)%><%else%><strong><%query%></strong><%endif%><%endif%> returned <strong><%cat_hits%></strong> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <strong><%link_hits%></strong> link<%if link_hits != 1%>s<%endif%>
        + </p>
        +
        + <%if category_results_loop.length~%>
        +@@ -36,7 +36,7 @@
        + <ul>
        + <%~loop category_results_loop%>
        +   <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>
        +-  <li><%if highlight%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%></li>
        ++  <li><%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%></li>
        + <%~endloop%>
        + </ul>
        + <%~endif%>
        +@@ -49,7 +49,7 @@
        + <%loop link_results_loop~%>
        + <%if title_loop.length%>
        +   <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>
        +-  <p class="category"><%if highlight%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%></p>
        ++  <p class="category"><%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%></p>
        + <%~endif%>
        + <%include link.html%>
        + <%~endloop%>
        +Index: signup_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/signup_form.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- signup_form.html    18 Apr 2005 21:39:36 -0000      1.14
        ++++ signup_form.html    11 May 2005 22:35:47 -0000      1.15
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: signup_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/signup_success.html,v
        +retrieving revision 1.9
        +retrieving revision 1.11
        +diff -u -r1.9 -r1.11
        +--- signup_success.html 24 Mar 2005 08:58:29 -0000      1.9
        ++++ signup_success.html 11 May 2005 22:35:47 -0000      1.11
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +@@ -24,7 +24,7 @@
        + <%~if Validation%>
        +   Thanks for signing up, an e-mail has been sent to you with a validation code. Once you receive it, you'll need to enter a <a href="<%config.db_cgi_url%>/user.cgi?validate=1">validation code</a>
        + <%~else%>
        +-  You have now successfully registered.  You may now <a href="<%config.db_cgi_url%>/user.cgi?Username=<%Username%>">log in</a>.
        ++  You have successfully registered.
        + <%~endif%>
        + </p>
        +
        +Index: validate_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/validate_form.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- validate_form.html  24 Mar 2005 08:58:29 -0000      1.10
        ++++ validate_form.html  11 May 2005 22:35:47 -0000      1.11
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +Index: validate_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/validate_success.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- validate_success.html       24 Mar 2005 08:58:29 -0000      1.9
        ++++ validate_success.html       11 May 2005 22:35:47 -0000      1.10
        +@@ -9,7 +9,7 @@
        +   <div id="wrapper">
        + <%include include_header.html%>
        + <%include include_contentheader.html%>
        +-    <div id="ocwrapper">
        ++    <div id="ocwrapper" class="clear">
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.2-3.0.3.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.2-3.0.3.diff.html new file mode 100644 index 0000000..db7ce14 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.2-3.0.3.diff.html @@ -0,0 +1,27 @@ + + +Gossamer Links 3.0.2 -> 3.0.3 "luna" template set diff + + + +
        +Index: include_common_head.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_common_head.html,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- include_common_head.html    4 Apr 2005 22:29:09 -0000       1.5
        ++++ include_common_head.html    4 Jun 2005 05:28:32 -0000       1.6
        +@@ -1,7 +1,7 @@
        + <meta http-equiv="content-type" content="text/html; charset=iso-8859-1" />
        + <%if Meta_Description%><meta name="description" content="<%Meta_Description%>" /><%endif%>
        + <%if Meta_Keywords%><meta name="keywords" content="<%Meta_Keywords%>" /><%endif%>
        +-<%if theme%><link type="text/css" rel="stylesheet" media="screen" href="<%config.build_static_url%>/<%t%>/<%theme%>.css" /><%endif%>
        ++<%if theme%><link type="text/css" rel="stylesheet" href="<%config.build_static_url%>/<%t%>/<%theme%>.css" /><%endif%>
        + <%~-- If your site is statically built, then the login status will always say 'Login/Register'.  This javascript replaces it with 'Logout' if the user is logged in. --~%>
        + <%if not d and not user.Username~%>
        + <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.3-3.0.4.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.3-3.0.4.diff.html new file mode 100644 index 0000000..6431537 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.3-3.0.4.diff.html @@ -0,0 +1,141 @@ + + +Gossamer Links 3.0.3 -> 3.0.4 "luna" template set diff + + + +
        +Index: luna/add_success.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/add_success.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- luna/add_success.html       11 May 2005 22:35:47 -0000      1.13
        ++++ luna/add_success.html       4 Jul 2005 23:12:23 -0000       1.14
        +@@ -30,7 +30,7 @@
        + </div>
        + <div class="row clear">
        +   <label class="name">URL:</label>
        +-  <div class="value wrappedtext"><%URL%></div>
        ++  <div class="value wrappedtext"><%escape_html URL%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Category:</label>
        +Index: luna/category.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.27
        +retrieving revision 1.28
        +diff -u -r1.27 -r1.28
        +--- luna/category.html  11 May 2005 22:35:47 -0000      1.27
        ++++ luna/category.html  4 Jul 2005 23:12:23 -0000       1.28
        +@@ -51,7 +51,7 @@
        + <h3>Related Categories</h3>
        + <ul>
        + <%~loop related_loop%>
        +-  <li><a href="<%URL%>"><%Full_Name%></a></li>
        ++  <li><a href="<%escape_html URL%>"><%Full_Name%></a></li>
        + <%~endloop%>
        + </ul>
        + <%endif%>
        +Index: luna/include_common_head.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/include_common_head.html,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -r1.6 -r1.7
        +--- luna/include_common_head.html       4 Jun 2005 05:28:32 -0000       1.6
        ++++ luna/include_common_head.html       24 Jun 2005 20:13:32 -0000      1.7
        +@@ -16,7 +16,7 @@
        +         return;
        +     var cookies = document.cookie.split(';');
        +     for (var i = 0; i < cookies.length; i++) {
        +-        if (cookies[i].match(/<%config.user_cookie_prefix%>s=[0-9a-f]+/)) {
        ++        if (cookies[i].match(/^\s*<%config.user_cookie_prefix%>s=[0-9a-f]{32}\s*$/)) {
        +             loginlink.href = '<%config.db_cgi_url%>/user.cgi?logout=1';
        +             loginlink.className = 'in';
        +             loginlink.firstChild.nodeValue = 'Logout';
        +Index: luna/jump_frame.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/jump_frame.html,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -r1.6 -r1.7
        +--- luna/jump_frame.html        7 Apr 2005 07:50:05 -0000       1.6
        ++++ luna/jump_frame.html        4 Jul 2005 23:12:23 -0000       1.7
        +@@ -22,7 +22,7 @@
        +       <a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Review Link</a>
        +       <a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate Link</a>
        +       <%if config.bookmark_enabled%><a href="<%config.db_cgi_url%>/bookmark.cgi?action=link_add;ID=<%ID%>">Bookmark Link</a><%endif%>
        +-      <a href="<%URL%>">Remove Frame</a>
        ++      <a href="<%escape_html URL%>">Remove Frame</a>
        +     </div>
        +   <%endif%>
        +   </div>
        +Index: luna/link.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link.html,v
        +retrieving revision 1.12
        +retrieving revision 1.14
        +diff -u -r1.12 -r1.14
        +--- luna/link.html      22 Mar 2005 02:01:36 -0000      1.12
        ++++ luna/link.html      5 Jul 2005 00:40:02 -0000       1.14
        +@@ -10,7 +10,7 @@
        +     <%if isFree%><span class="free-item"><span>free</span></span><%endif%>
        +   <%~endif%>
        +   </h4>
        +-  <%if URL ne 'http://'%><p class="linkurl"><%if isValidated eq 'Yes'%><a href="<%config.db_cgi_url%>/jump.cgi?ID=<%ID%>"><%endif%><%if highlight%><%Links::Tools::highlight($URL, $query)%><%else%><%URL%><%endif%><%if isValidated eq 'Yes'%></a><%endif%></p><%endif%>
        ++  <%if URL ne 'http://'%><p class="linkurl"><%if isValidated eq 'Yes'%><a href="<%config.db_cgi_url%>/jump.cgi?ID=<%ID%>"><%endif%><%if highlight%><%set equery = escape_html $query%><%set eURL = escape_html $URL%><%Links::Tools::highlight($eURL, $equery)%><%else%><%escape_html URL%><%endif%><%if isValidated eq 'Yes'%></a><%endif%></p><%endif%>
        +
        +   <p class="linkrating">
        +   <%~if Votes%>
        +Index: luna/modify_success.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/modify_success.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- luna/modify_success.html    11 May 2005 22:35:47 -0000      1.12
        ++++ luna/modify_success.html    4 Jul 2005 23:12:23 -0000       1.13
        +@@ -34,7 +34,7 @@
        + </div>
        + <div class="row clear">
        +   <label class="name">URL:</label>
        +-  <div class="value wrappedtext"><%URL%></div>
        ++  <div class="value wrappedtext"><%escape_html URL%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Category:</label>
        +Index: luna/search_results.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/search_results.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- luna/search_results.html    11 May 2005 22:35:47 -0000      1.17
        ++++ luna/search_results.html    5 Jul 2005 00:40:02 -0000       1.18
        +@@ -27,7 +27,7 @@
        + <h2>Search Results</h2>
        +
        + <p>
        +-  Your search<%if query%> for <%if highlight%><%Links::Tools::highlight($query, $query)%><%else%><strong><%query%></strong><%endif%><%endif%> returned <strong><%cat_hits%></strong> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <strong><%link_hits%></strong> link<%if link_hits != 1%>s<%endif%>
        ++  Your search<%if query%> for <%if highlight%><%set equery = escape_html $query%><%Links::Tools::highlight($equery, $equery)%><%else%><strong><%escape_html query%></strong><%endif%><%endif%> returned <strong><%cat_hits%></strong> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <strong><%link_hits%></strong> link<%if link_hits != 1%>s<%endif%>
        + </p>
        +
        + <%if category_results_loop.length~%>
        +Index: luna/subcategory.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/subcategory.html,v
        +retrieving revision 1.3
        +retrieving revision 1.5
        +diff -u -r1.3 -r1.5
        +--- luna/subcategory.html       13 Apr 2005 02:06:35 -0000      1.3
        ++++ luna/subcategory.html       4 Jul 2005 23:12:23 -0000       1.5
        +@@ -1,2 +1,2 @@
        +-<dt><a href="<%URL%>"><%Name%><%if Related%>@<%endif%></a> (<%Number_of_Links%>)<%if Has_New_Links eq 'Yes'%> <span class="new-item"><span>new</span></span><%endif%><%if Has_Changed_Links eq 'Yes'%> <span class="updated-item"><span>updated</span></span><%endif%></dt>
        ++<dt><a href="<%escape_html URL%>"><%if RelationName%><%RelationName%><%else%><%Name%><%endif%><%if Related%>@<%endif%></a> (<%Number_of_Links%>)<%if Has_New_Links eq 'Yes'%> <span class="new-item"><span>new</span></span><%endif%><%if Has_Changed_Links eq 'Yes'%> <span class="updated-item"><span>updated</span></span><%endif%></dt>
        + <%if Description%><dd><%Description%></dd><%endif%>
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.css.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.css.diff.html new file mode 100644 index 0000000..81c4599 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.css.diff.html @@ -0,0 +1,36 @@ + + +Gossamer Links 3.0.4 -> 3.1.0 "luna" template set CSS diff + + + +
        +Index: luna_core.css
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/html/static/luna/luna_core.css,v
        +retrieving revision 1.28
        +retrieving revision 1.30
        +diff -u -r1.28 -r1.30
        +--- luna_core.css       18 May 2005 23:26:59 -0000      1.28
        ++++ luna_core.css       5 Jan 2006 20:56:24 -0000       1.30
        +@@ -493,7 +493,7 @@
        + .paging {
        +   text-align: right;
        + }
        +-.paging img, .paging select {
        ++.paging img, .paging select, .paging input {
        +   vertical-align: middle;
        + }
        +
        +@@ -535,8 +535,6 @@
        + #content ul {
        +   margin: 10px 0px 0px 20px;
        +   padding: 0px;
        +-}
        +-#content li {
        +   font-size: 12px;
        +   list-style: none;
        + }
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.diff.html new file mode 100644 index 0000000..2933661 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.0.4-3.1.0.diff.html @@ -0,0 +1,416 @@ + + +Gossamer Links 3.0.4 -> 3.1.0 "luna" template set diff + + + +
        +Index: luna/bookmark_folder_view.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/bookmark_folder_view.html,v
        +retrieving revision 1.15
        +retrieving revision 1.17
        +diff -u -r1.15 -r1.17
        +--- luna/bookmark_folder_view.html      11 May 2005 22:35:47 -0000      1.15
        ++++ luna/bookmark_folder_view.html      4 Jan 2006 04:58:06 -0000       1.17
        +@@ -4,12 +4,6 @@
        + <head>
        +   <title><%site_title%>: Bookmarks: <%my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="bookmark_folder_view">
        + <%include include_accessibility.html%>
        +@@ -35,6 +29,8 @@
        + <%~endif%>
        + </p>
        +
        ++<%if paging.num_hits%><div class="paging"><%Links::Utils::paging()%></div><%endif%>
        ++
        + <%if Folders.length~%>
        + <ul class="folders">
        + <%~loop Folders%>
        +@@ -46,8 +42,6 @@
        + </ul>
        + <%~endif%>
        +
        +-<%if paging.num_hits%><div class="paging"><%Links::Utils::paging()%></div><%endif%>
        +-
        + <%if Bookmarks.length~%>
        + <%~loop Bookmarks%>
        + <p class="category"><%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%></p>
        +Index: luna/bookmark_list.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/bookmark_list.html,v
        +retrieving revision 1.14
        +retrieving revision 1.16
        +diff -u -r1.14 -r1.16
        +--- luna/bookmark_list.html     11 May 2005 22:35:47 -0000      1.14
        ++++ luna/bookmark_list.html     4 Jan 2006 01:38:36 -0000       1.16
        +@@ -4,12 +4,6 @@
        + <head>
        +   <title><%site_title%>: <%if my_folder_name%>Bookmarks: <%my_folder_name%><%else%>My Bookmarks<%endif%></title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="bookmark_list">
        + <%include include_accessibility.html%>
        +@@ -35,6 +29,8 @@
        + <%~endif%>
        + </p>
        +
        ++<%if paging.num_hits%><div class="paging"><%Links::Utils::paging()%></div><%endif%>
        ++
        + <%if Folders.length~%>
        + <ul class="folders">
        + <%~loop Folders%>
        +@@ -51,8 +47,6 @@
        + </ul>
        + <%~endif%>
        +
        +-<%if paging.num_hits%><div class="paging"><%Links::Utils::paging()%></div><%endif%>
        +-
        + <%if Bookmarks.length~%>
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="links_manage" />
        +Index: luna/bookmark_users.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/bookmark_users.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- luna/bookmark_users.html    11 May 2005 22:35:47 -0000      1.12
        ++++ luna/bookmark_users.html    19 Aug 2005 20:07:57 -0000      1.13
        +@@ -4,12 +4,6 @@
        + <head>
        +   <title><%site_title%>: Bookmarks: User List</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="bookmark_users">
        + <%include include_accessibility.html%>
        +Index: luna/category.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.28
        +retrieving revision 1.29
        +diff -u -r1.28 -r1.29
        +--- luna/category.html  4 Jul 2005 23:12:23 -0000       1.28
        ++++ luna/category.html  19 Aug 2005 20:07:57 -0000      1.29
        +@@ -5,12 +5,6 @@
        + <head>
        +   <title><%site_title%>: <%category_name%></title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="category">
        + <%include include_accessibility.html%>
        +Index: luna/cool.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/cool.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/cool.html      11 May 2005 22:35:47 -0000      1.14
        ++++ luna/cool.html      19 Aug 2005 20:07:57 -0000      1.15
        +@@ -3,12 +3,6 @@
        + <head>
        +   <title><%site_title%>: What's Cool</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="cool">
        + <%include include_accessibility.html%>
        +Index: luna/language.txt
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/language.txt,v
        +retrieving revision 1.18
        +retrieving revision 1.19
        +diff -u -r1.18 -r1.19
        +--- luna/language.txt   12 May 2005 20:51:55 -0000      1.18
        ++++ luna/language.txt   19 Jan 2006 21:43:09 -0000      1.19
        +@@ -3,6 +3,7 @@
        +        'ADD_BADSTATUS' => 'Your link could not be added because it is not accessible: %s.',
        +        'ADD_ILLEGALVAL' => '%s can not contain the value \'%s\'',
        +        'ADD_INVALIDCAT' => 'Unable to find category with ID \'%s\'.',
        ++       'ADD_NOCATEGORIES' => 'There are no categories to add a link to.',
        +        'ADD_NOCATEGORY' => 'You did not specify a category for this link.',
        +        'ADD_NOTNULL' => 'Column %s can not be left blank.',
        +        'ADD_SELCAT' => 'Please first visit the category you wish to add your link to, then click on Add.',
        +Index: luna/link.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/link.html      5 Jul 2005 00:40:02 -0000       1.14
        ++++ luna/link.html      10 Feb 2006 01:26:18 -0000      1.15
        +@@ -17,7 +17,7 @@
        +     <%~set intRating = $Rating i/ 1%>
        +     <img src="<%Links::Utils::image_url("stars-10-${intRating}.gif")%>" alt="<%intRating%> out of 10 stars" title="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>)
        +   <%~endif%>
        +-  <%~if paymentsEnabled and ExpiryDateFormatted and not isFree%>
        ++  <%~if paymentsEnabled and ExpiryDateFormatted and wasPaid%>
        +     <%if isNotify or isExpired%><span class="linkexpired"><%endif%><%if isExpired%>Expired on:<%else%>Expiry date:<%endif%> <%ExpiryDateFormatted%><%if isNotify or isExpired%></span><%endif%>
        +   <%~endif%>
        +   </p>
        +@@ -32,6 +32,6 @@
        +     <%if config.bookmark_enabled%><a href="<%config.db_cgi_url%>/bookmark.cgi?action=link_add;ID=<%ID%>">Bookmark It</a><%endif%>
        +     <%if isLinkOwner%><a href="<%config.db_cgi_url%>/modify.cgi?LinkID=<%ID%>">Edit this link</a><%endif%>
        +   <%~endif%>
        +-    <%if paymentsEnabled%><a href="<%config.db_cgi_url%>/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=<%ID%>"><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%></a><%endif%>
        ++  <%if paymentsEnabled%><a href="<%config.db_cgi_url%>/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=<%ID%>"><%if not wasPaid%>New Payment<%else%>Renewal Payment<%endif%></a><%endif%>
        +   </p>
        + </div>
        +Index: luna/link_added.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link_added.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/link_added.eml 14 Mar 2005 23:13:40 -0000      1.5
        ++++ luna/link_added.eml 27 Oct 2005 23:25:24 -0000      1.6
        +@@ -1,4 +1,4 @@
        +-To: <%if Contact_Email%><%if Contact_Name%><%Contact_Name%> <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your link has been approved
        +
        +Index: luna/link_expired.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link_expired.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -r1.6 -r1.7
        +--- luna/link_expired.eml       14 Mar 2005 23:13:40 -0000      1.6
        ++++ luna/link_expired.eml       27 Oct 2005 23:25:24 -0000      1.7
        +@@ -1,4 +1,4 @@
        +-To: <%if Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Expiry Notification
        +
        +Index: luna/link_expiry_notify.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link_expiry_notify.eml,v
        +retrieving revision 1.7
        +retrieving revision 1.8
        +diff -u -r1.7 -r1.8
        +--- luna/link_expiry_notify.eml 21 Apr 2005 19:49:17 -0000      1.7
        ++++ luna/link_expiry_notify.eml 27 Oct 2005 23:25:24 -0000      1.8
        +@@ -1,4 +1,4 @@
        +-To: <%if Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Expiry Notification
        +
        +Index: luna/link_modified.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link_modified.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/link_modified.eml      14 Mar 2005 23:13:40 -0000      1.5
        ++++ luna/link_modified.eml      27 Oct 2005 23:25:24 -0000      1.6
        +@@ -1,4 +1,4 @@
        +-To: <%if Contact_Email%><%if Contact_Name%><%Contact_Name%> <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your link has been successfully updated
        +
        +Index: luna/link_rejected.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/link_rejected.eml,v
        +retrieving revision 1.3
        +retrieving revision 1.4
        +diff -u -r1.3 -r1.4
        +--- luna/link_rejected.eml      15 Feb 2005 20:31:38 -0000      1.3
        ++++ luna/link_rejected.eml      27 Oct 2005 23:25:24 -0000      1.4
        +@@ -1,4 +1,4 @@
        +-To: <%if Contact_Email%><%if Contact_Name%><%Contact_Name%> <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your <%if modify%>change<%else%>link<%endif%> has been rejected
        +
        +Index: luna/modify_select.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/modify_select.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/modify_select.html     11 May 2005 22:35:47 -0000      1.14
        ++++ luna/modify_select.html     19 Aug 2005 20:07:57 -0000      1.15
        +@@ -3,12 +3,6 @@
        + <head>
        +   <title><%site_title%>: Modify a Link</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="modify_select">
        + <%include include_accessibility.html%>
        +Index: luna/new.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/new.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- luna/new.html       11 May 2005 22:35:47 -0000      1.13
        ++++ luna/new.html       19 Aug 2005 20:07:57 -0000      1.14
        +@@ -3,12 +3,6 @@
        + <head>
        +   <title><%site_title%>: New Links</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="new">
        + <%include include_accessibility.html%>
        +Index: luna/password.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/password.eml,v
        +retrieving revision 1.4
        +retrieving revision 1.5
        +diff -u -r1.4 -r1.5
        +--- luna/password.eml   15 Feb 2005 20:31:38 -0000      1.4
        ++++ luna/password.eml   27 Oct 2005 23:25:24 -0000      1.5
        +@@ -1,4 +1,4 @@
        +-To: <%if Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your password you requested
        +
        +Index: luna/payment_received.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/payment_received.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/payment_received.eml   14 Mar 2005 23:13:40 -0000      1.5
        ++++ luna/payment_received.eml   27 Oct 2005 23:25:24 -0000      1.6
        +@@ -1,4 +1,4 @@
        +-To: <%if Contact_Email%><%if Contact_Name%><%Contact_Name%> <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Payment has been received and your link has been added
        +
        +Index: luna/review_added.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/review_added.eml,v
        +retrieving revision 1.7
        +retrieving revision 1.8
        +diff -u -r1.7 -r1.8
        +--- luna/review_added.eml       15 Apr 2005 00:07:25 -0000      1.7
        ++++ luna/review_added.eml       27 Oct 2005 23:25:24 -0000      1.8
        +@@ -1,4 +1,4 @@
        +-To: <%if Review_GuestEmail%><%if Review_GuestName%><%Review_GuestName%> <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Review_GuestEmail%><%if Review_GuestName%>"<%Review_GuestName%>" <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your review has been approved
        +
        +Index: luna/review_rejected.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/review_rejected.eml,v
        +retrieving revision 1.4
        +retrieving revision 1.5
        +diff -u -r1.4 -r1.5
        +--- luna/review_rejected.eml    14 Mar 2005 23:13:40 -0000      1.4
        ++++ luna/review_rejected.eml    27 Oct 2005 23:25:24 -0000      1.5
        +@@ -1,4 +1,4 @@
        +-To: <%if Review_GuestEmail%><%if Review_GuestName%><%Review_GuestName%> <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Review_GuestEmail%><%if Review_GuestName%>"<%Review_GuestName%>" <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your review has been rejected
        +
        +Index: luna/review_search_results.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/review_search_results.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/review_search_results.html     11 May 2005 22:35:47 -0000      1.14
        ++++ luna/review_search_results.html     19 Aug 2005 20:07:57 -0000      1.15
        +@@ -3,12 +3,6 @@
        + <head>
        +   <title><%site_title%>: Reviews</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="review_search_results">
        + <%include include_accessibility.html%>
        +Index: luna/search_results.html
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/search_results.html,v
        +retrieving revision 1.18
        +retrieving revision 1.19
        +diff -u -r1.18 -r1.19
        +--- luna/search_results.html    5 Jul 2005 00:40:02 -0000       1.18
        ++++ luna/search_results.html    19 Aug 2005 20:07:57 -0000      1.19
        +@@ -3,12 +3,6 @@
        + <head>
        +   <title><%site_title%>: Search Results</title>
        + <%include include_common_head.html%>
        +-  <script type="text/javascript" src="<%config.build_static_url%>/utils.js"></script>
        +-  <script type="text/javascript">
        +-    //<![CDATA[
        +-registerEvent(window, 'onload', function () { hideObjects('paging_button', 'paging_button2') });
        +-    //!]]>
        +-  </script>
        + </head>
        + <body id="search_results">
        + <%include include_accessibility.html%>
        +Index: luna/validate.eml
        +===================================================================
        +RCS file: /cvs/gossamer/glinks/cgi/admin/templates/luna/validate.eml,v
        +retrieving revision 1.4
        +retrieving revision 1.5
        +diff -u -r1.4 -r1.5
        +--- luna/validate.eml   14 Mar 2005 23:13:40 -0000      1.4
        ++++ luna/validate.eml   27 Oct 2005 23:25:24 -0000      1.5
        +@@ -1,4 +1,4 @@
        +-To: <%if Name%><%Name%> <<%Email%>><%else%><%Email%><%endif%>
        ++To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%>
        + From: <%config.db_admin_email%>
        + Subject: Your validation code
        +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.css.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.css.diff.html new file mode 100644 index 0000000..63b351d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.css.diff.html @@ -0,0 +1,97 @@ + + +Gossamer Links 3.1.0 -> 3.2.0 "luna" template set CSS diff + + + +
        +Index: luna_core.css
        +===================================================================
        +RCS file: /glinks/html/static/luna/luna_core.css,v
        +retrieving revision 1.30
        +retrieving revision 1.38
        +diff -u -r1.30 -r1.38
        +--- luna_core.css       5 Jan 2006 20:56:24 -0000       1.30
        ++++ luna_core.css       11 Aug 2006 04:30:25 -0000      1.38
        +@@ -22,7 +22,7 @@
        + There are a few CSS filters/hacks used in this file to fix bugs in various
        + browsers.  Here is a list of them:
        +
        +-- Star html selector bug (css rule only applies to ie/win)
        ++- Star html selector bug (css rule only applies to ie)
        +     http://www.info.com.ph/~etan/w3pantheon/style/starhtmlbug.html
        +     eg. * html <selector> {}
        + - Simplified box model hack (hide css from ie5-5.5/win)
        +@@ -316,7 +316,7 @@
        +   margin-right: -200px;
        +   padding: 10px 10px 10px 0px;
        +   width: 190px;
        +-  float: left;
        ++  float: right;
        +   position: relative;
        + }
        + #contentwrapper {
        +@@ -538,6 +538,9 @@
        +   font-size: 12px;
        +   list-style: none;
        + }
        ++#content ul.categories {
        ++  margin: 0px;
        ++}
        +
        + /* forms */
        + .row {
        +@@ -590,6 +593,50 @@
        +   font-weight: bold;
        + }
        +
        ++/* treecats */
        ++#content .treecats-selection-summary ul, #content .treecats-selection ul {
        ++  margin: 0px;
        ++}
        ++.treecats-selection-summary li a, .treecats-selection li a {
        ++  margin-top: 2px;
        ++  margin-left: 5px;
        ++}
        ++.treecats-selection-summary a, .treecats-selection a {
        ++  font-size: 9px;
        ++}
        ++.treecats-selection-summary a:visited, .treecats-selection a:visited {
        ++  color: #212126;
        ++}
        ++.treecats-selection-current {
        ++  font-weight: bold;
        ++}
        ++.treecats-category-info img {
        ++  border: 0px;
        ++  padding: 2px;
        ++  vertical-align: middle;
        ++}
        ++.treecats-children {
        ++  padding-left: 15px;
        ++}
        ++.treecats-selected span, li.treecats-selected {
        ++  font-weight: bold;
        ++}
        ++.treecats-category a:link, .treecats-category a:visited {
        ++  color: #212126;
        ++  text-decoration: none;
        ++}
        ++.treecats-category a:hover {
        ++  text-decoration: underline;
        ++}
        ++#content ul.treecats-links {
        ++  padding-left: 15px;
        ++  margin: 0px;
        ++}
        ++.treecats-links li {
        ++  line-height: 1.25em;
        ++  list-style: circle;
        ++}
        ++
        + /* search highlighting */
        + .searchhl-1, .searchhl-2, .searchhl-3, .searchhl-4, .searchhl-5 {
        +   font-weight: bold;
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.diff.html new file mode 100644 index 0000000..a1cfe05 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.1.0-3.2.0.diff.html @@ -0,0 +1,1807 @@ + + +Gossamer Links 3.1.0 -> 3.2.0 "luna" template set diff + + + +
        +Index: add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/add.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- add.html    11 May 2005 22:35:47 -0000      1.10
        ++++ add.html    23 Aug 2006 20:53:31 -0000      1.11
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Add a Link</h2>
        +@@ -31,9 +33,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/add_success.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- add_success.html    4 Jul 2005 23:12:23 -0000       1.14
        ++++ add_success.html    23 Aug 2006 20:53:31 -0000      1.15
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Link Added</h2>
        +@@ -63,9 +65,11 @@
        + <%~endif%>
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_folder_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_add.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- bookmark_folder_add.html    11 May 2005 22:35:47 -0000      1.14
        ++++ bookmark_folder_add.html    23 Aug 2006 20:53:31 -0000      1.15
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Add Folder</h2>
        +@@ -54,9 +56,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_folder_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_edit.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- bookmark_folder_edit.html   11 May 2005 22:35:47 -0000      1.13
        ++++ bookmark_folder_edit.html   23 Aug 2006 20:53:31 -0000      1.14
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Edit Folder</h2>
        +@@ -55,9 +57,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_folder_view.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_folder_view.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- bookmark_folder_view.html   4 Jan 2006 04:58:06 -0000       1.17
        ++++ bookmark_folder_view.html   23 Aug 2006 20:53:31 -0000      1.18
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2><%my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></h2>
        +@@ -51,9 +53,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_link_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_add.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- bookmark_link_add.html      11 May 2005 22:35:47 -0000      1.17
        ++++ bookmark_link_add.html      23 Aug 2006 20:53:31 -0000      1.18
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Add Bookmark</h2>
        +@@ -55,9 +57,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_link_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_link_edit.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- bookmark_link_edit.html     11 May 2005 22:35:47 -0000      1.17
        ++++ bookmark_link_edit.html     23 Aug 2006 20:53:31 -0000      1.18
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Edit Bookmark</h2>
        +@@ -55,9 +57,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_list.html,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -r1.16 -r1.17
        +--- bookmark_list.html  4 Jan 2006 01:38:36 -0000       1.16
        ++++ bookmark_list.html  23 Aug 2006 20:53:31 -0000      1.17
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2><%if my_folder_name%><%my_folder_name%><%else%>My Bookmarks<%endif%></h2>
        +@@ -68,9 +70,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_preferences.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_preferences.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- bookmark_preferences.html   11 May 2005 22:35:47 -0000      1.14
        ++++ bookmark_preferences.html   23 Aug 2006 20:53:31 -0000      1.15
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Preferences</h2>
        +@@ -61,9 +63,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: bookmark_users.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/bookmark_users.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- bookmark_users.html 19 Aug 2005 20:07:57 -0000      1.13
        ++++ bookmark_users.html 23 Aug 2006 20:53:31 -0000      1.14
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>User List</h2>
        +@@ -41,9 +43,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: category.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.29
        +retrieving revision 1.31
        +diff -u -r1.29 -r1.31
        +--- category.html       19 Aug 2005 20:07:57 -0000      1.29
        ++++ category.html       23 Aug 2006 20:53:31 -0000      1.31
        +@@ -1,4 +1,3 @@
        +-<%if Category_Template and Category_Template ne 'category.html'%><%include $Category_Template%><%endparse%><%endif~%>
        + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
        + <%Links::Utils::load_editors~%>
        + <html>
        +@@ -15,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>
        +@@ -70,9 +71,11 @@
        + </ul>
        + <%~endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: cool.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/cool.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- cool.html   19 Aug 2005 20:07:57 -0000      1.15
        ++++ cool.html   23 Aug 2006 20:53:31 -0000      1.16
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Cool Links (top <%percent%>)</h2>
        +@@ -29,9 +31,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: detailed.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/detailed.html,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -r1.16 -r1.17
        +--- detailed.html       11 May 2005 22:35:47 -0000      1.16
        ++++ detailed.html       23 Aug 2006 20:53:31 -0000      1.17
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        +
        +@@ -70,9 +72,11 @@
        + <%if Review_Total > $Review_Loop.length%><p class="reviewsfooter"><a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>">Read all <%Review_Total%> review<%if Review_Total != 1%>s<%endif%></a></p><%endif%>
        + <%~endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: error.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/error.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- error.html  11 May 2005 22:35:47 -0000      1.11
        ++++ error.html  23 Aug 2006 20:53:31 -0000      1.12
        +@@ -15,9 +15,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Error</h2>
        +@@ -29,9 +31,11 @@
        +   <%error_message%>
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: home.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/home.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- home.html   11 May 2005 22:35:47 -0000      1.15
        ++++ home.html   23 Aug 2006 20:53:31 -0000      1.16
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <%set split = Links::Utils::column_split($category_loop.length, $home_category_cols)~%>
        + <div class="clear">
        +@@ -28,9 +30,11 @@
        + </div>
        + <h4>There <%if grand_total != 1%>are<%else%>is<%endif%> <strong><%grand_total%></strong> link<%if grand_total != 1%>s<%endif%> for you to choose from!</h4>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: include_common_head.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_common_head.html,v
        +retrieving revision 1.7
        +retrieving revision 1.8
        +diff -u -r1.7 -r1.8
        +--- include_common_head.html    24 Jun 2005 20:13:32 -0000      1.7
        ++++ include_common_head.html    28 Jul 2006 21:02:17 -0000      1.8
        +@@ -1,4 +1,4 @@
        +-<meta http-equiv="content-type" content="text/html; charset=iso-8859-1" />
        ++<meta http-equiv="content-type" content="text/html; charset=<%config.header_charset || iso-8859-1%>" />
        + <%if Meta_Description%><meta name="description" content="<%Meta_Description%>" /><%endif%>
        + <%if Meta_Keywords%><meta name="keywords" content="<%Meta_Keywords%>" /><%endif%>
        + <%if theme%><link type="text/css" rel="stylesheet" href="<%config.build_static_url%>/<%t%>/<%theme%>.css" /><%endif%>
        +Index: include_footer.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_footer.html,v
        +retrieving revision 1.6
        +retrieving revision 1.7
        +diff -u -r1.6 -r1.7
        +--- include_footer.html 22 Mar 2005 02:01:36 -0000      1.6
        ++++ include_footer.html 11 Aug 2006 07:51:23 -0000      1.7
        +@@ -1,6 +1,6 @@
        + <hr class="hide" />
        + <div id="footer" class="clear">
        +   <a href="http://www.gossamer-threads.com"><img src="<%Links::Utils::image_url('poweredby.gif')%>" alt="Powered by Gossamer Links" /></a>
        +-  <p>&copy; 2005 Gossamer Threads Inc.</p>
        ++  <p>&copy; 2006 Gossamer Threads Inc.</p>
        + </div>
        + <%--if in.debug%><%DUMP%><%endif--%>
        +Index: include_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/include_form.html,v
        +retrieving revision 1.10
        +retrieving revision 1.14
        +diff -u -r1.10 -r1.14
        +--- include_form.html   18 Apr 2005 21:39:36 -0000      1.10
        ++++ include_form.html   19 Aug 2006 03:23:10 -0000      1.14
        +@@ -12,20 +12,41 @@
        + </div>
        + <div class="row<%unless category_loop_selected%> required<%endunless%> clear">
        +   <label for="CatLinks.CategoryID" class="name">Category:<%unless category_loop_selected%> <span>*</span><%endunless%></label>
        +-  <div class="value<%if category_loop_selected%> wrappedtext<%endif%>">
        +-  <%if category_loop_selected%>
        +-    <%if category_loop.length > 1%>
        +-    <ul><%loop category_loop%><li><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" /></li><%endloop%></ul>
        +-    <%else%>
        ++  <div class="value wrappedtext">
        ++  <%~if config.db_gen_category_list == 2%>
        ++    <script type="text/javascript" src="<%config.build_static_url%>/treecats.js"></script>
        ++    <%~set selected_cats = Links::Tools::category_list_selected%>
        ++    <%~loop selected_cats%>
        ++    <input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" />
        ++    <%~endloop%>
        ++    <noscript>
        ++      <ul class="categories">
        ++      <%~loop selected_cats%>
        ++        <li><%Full_Name%></li>
        ++      <%~endloop%>
        ++      <%~if not selected_cats.length%>
        ++        <li><%Links::language('ADD_SELCAT')%></li>
        ++      <%~endif%>
        ++      </ul>
        ++    </noscript>
        ++    <div id="treecats"></div>
        ++    <script type="text/javascript">
        ++      var tc = new treecats({ <%-- selectionMode : 'multiple', --%> cgiURL : '<%config.db_cgi_url%>', imageURL : '<%config.build_static_url%>/<%t%>/images' });
        ++      tc.load();
        ++    </script>
        ++  <%~elsif category_loop_selected%>
        ++    <%~if category_loop.length > 1%>
        ++    <ul class="categories"><%loop category_loop%><li><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" /></li><%endloop%></ul>
        ++    <%~else%>
        +     <%loop category_loop%><%Full_Name%><input type="hidden" name="CatLinks.CategoryID" value="<%escape_html ID%>" /><%endloop%>
        +-    <%endif%>
        +-  <%else%>
        ++    <%~endif%>
        ++  <%~else%>
        +     <select id="CatLinks.CategoryID" name="CatLinks.CategoryID">
        +-      <%loop category_loop%>
        ++      <%~loop category_loop%>
        +       <option value="<%escape_html ID%>"<%if selected%> selected="selected"<%endif%>><%'&nbsp;&nbsp;' x $CatDepth%><%Name%></option>
        +-      <%endloop%>
        ++      <%~endloop%>
        +     </select>
        +-  <%endif%>
        ++  <%~endif%>
        +   </div>
        + </div>
        + <div class="row clear">
        +Index: language.txt
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/language.txt,v
        +retrieving revision 1.20
        +retrieving revision 1.24
        +diff -u -r1.20 -r1.24
        +--- language.txt        14 Feb 2006 00:27:03 -0000      1.20
        ++++ language.txt        11 Aug 2006 23:46:45 -0000      1.24
        +@@ -6,7 +6,7 @@
        +        'ADD_NOCATEGORIES' => 'There are no categories to add a link to.',
        +        'ADD_NOCATEGORY' => 'You did not specify a category for this link.',
        +        'ADD_NOTNULL' => 'Column %s cannot be left blank.',
        +-       'ADD_SELCAT' => 'Please first visit the category you wish to add your link to, then click on Add.',
        ++       'ADD_SELCAT' => 'Please first visit the category you wish to add or move your link to, then click on Add/Modify a Link.',
        +        'ADD_UNIQUE' => 'The column \'%s\' must be unique, and already has an entry \'%s\'.',
        +        'BOOKMARK_BAD_FOLDER' => 'Please enter a valid folder name.',
        +        'BOOKMARK_BAD_FOLDER_ID' => 'There is no folder with the id \'%s\'.',
        +@@ -23,7 +23,7 @@
        +        'BOOKMARK_FOLDER_NO_MOVE' => 'You cannot move links to the folder with id \'%s\'.',
        +        'BOOKMARK_FOLDER_REMOVED' => 'The folder %s has been removed.',
        +        'BOOKMARK_LINK_ADDED' => 'The link has been bookmarked.',
        +-       'BOOKMARK_LINK_EXISTS' => 'You have already bookmarked this link.',
        ++       'BOOKMARK_LINK_EXISTS' => 'This link has already been bookmarked in the selected folder.',
        +        'BOOKMARK_LINK_LIMIT' => 'You may not add any more links as you have reached your limit.',
        +        'BOOKMARK_LINK_MOVED' => '%s link(s) have been moved to folder %s.',
        +        'BOOKMARK_LINK_NOTEXISTS' => 'The link with id \'%s\' doesn\'t exist in your bookmarks.',
        +@@ -79,6 +79,7 @@
        +        'LINKS_VALIDATE' => 'Validation',
        +        'MODIFY_BADSTATUS' => 'Your link could not be modified because it is not accessible: %s.',
        +        'MODIFY_BADURL' => 'We were unable to find the URL \'%s\' in the database.  Please make sure you typed it in exactly as it appears in the directory.',
        ++       'MODIFY_INVALIDLINKID' => 'Invalid link ID.',
        +        'MODIFY_NOCATEGORY' => 'You did not specify a category for this link.',
        +        'MODIFY_NOLINKS' => 'You do not have any links to modify.',
        +        'MODIFY_NOTOWNER' => 'You are not authorized to modify this link.',
        +@@ -109,7 +110,7 @@
        +        'PAYMENTERR_INVALIDTERM' => 'You have selected an invalid payment term.',
        +        'PAYMENTERR_NOLEVEL' => 'You must select a payment level.',
        +        'PAYMENTERR_NOMETHOD' => 'You must select a payment method.',
        +-       'PAYMENTERR_NOTACCEPTED' => 'Payments are not accepted for the link the category is in.',
        ++       'PAYMENTERR_NOTACCEPTED' => 'Payments are not accepted for the category the link is in.',
        +        'PAYMENTERR_NOTOWNER' => 'You can only make payments to your own links.',
        +        'PAYMENT_CURRENCY_FORMAT' => '$%s ',
        +        'PAYMENT_DIRECT_AuthorizeDotNet' => 'Authorize.Net',
        +@@ -149,7 +150,9 @@
        +        'REVIEW_INVALIDID' => 'Invalid Link ID : %s.',
        +        'REVIEW_INVALID_ACTION' => 'Invalid action!',
        +        'REVIEW_INVALID_UPDATE' => 'Unable to update review database. User is invalid for this review or the review is not validated.',
        +-       'REVIEW_MODIFY_DENIED' => 'You have already reviewed this link.  Reviews cannot be modified.',
        ++       'REVIEW_MAX_REVIEWS' => 'You can only add %s review(s) to a link.',
        ++       'REVIEW_MODIFY_DENIED' => 'You do not have permission to modify your review.',
        ++       'REVIEW_MODIFY_TIMEOUT' => 'The edit time for the review has expired.',
        +        'REVIEW_NORESULTS' => 'No reviews are available.',
        +        'REVIEW_NOT_EXISTS' => 'Review doesn\'t exist!',
        +        'REVIEW_RATING' => 'Please select a rating from 1 to 5 only.',
        +Index: link.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/link.html,v
        +retrieving revision 1.15
        +retrieving revision 1.20
        +diff -u -r1.15 -r1.20
        +--- link.html   10 Feb 2006 01:26:18 -0000      1.15
        ++++ link.html   12 Jul 2006 01:49:36 -0000      1.20
        +@@ -25,12 +25,14 @@
        +   <%if Description%><div class="linkdescription"><%if highlight%><%Links::Tools::highlight($Description, $query)%><%else%><%Description%><%endif%></div><%endif%>
        +
        +   <p class="linkactions">
        +-  <%~if isValidated eq 'Yes'%>
        ++  <%~if isValidated eq Yes%>
        +     <%if Review_Count%><a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>">Read <%Review_Count%> Review<%if Review_Count != 1%>s<%endif%></a><%endif%>
        +     <a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Review It</a>
        +     <a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It</a>
        +     <%if config.bookmark_enabled%><a href="<%config.db_cgi_url%>/bookmark.cgi?action=link_add;ID=<%ID%>">Bookmark It</a><%endif%>
        +-    <%if isLinkOwner%><a href="<%config.db_cgi_url%>/modify.cgi?LinkID=<%ID%>">Edit this link</a><%endif%>
        ++    <%if not isExpired and not isUnpaid%>
        ++      <%if isLinkOwner or not config.user_required%><a href="<%config.db_cgi_url%>/modify.cgi?LinkID=<%ID%>">Edit this link</a><%endif%>
        ++    <%endif%>
        +   <%~endif%>
        +   <%if paymentsEnabled%><a href="<%config.db_cgi_url%>/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=<%ID%>"><%if not wasPaid%>New Payment<%else%>Renewal Payment<%endif%></a><%endif%>
        +   </p>
        +Index: login.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login.html,v
        +retrieving revision 1.16
        +retrieving revision 1.21
        +diff -u -r1.16 -r1.21
        +--- login.html  11 May 2005 22:35:47 -0000      1.16
        ++++ login.html  23 Aug 2006 20:53:31 -0000      1.21
        +@@ -1,4 +1,11 @@
        + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
        ++<%~if logout and error%>
        ++  <%~set message = $error%>
        ++  <%~set error = ''%>
        ++<%~endif%>
        ++<%~if url and not error%>
        ++  <%~set error = 'You must first login before you can access that.'%>
        ++<%~endif%>
        + <html>
        + <head>
        +   <title><%site_title%>: User Login</title>
        +@@ -13,14 +20,15 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>User Login</h2>
        +
        +-<%if url%><p>You must first login before you can access that.</p><%endif%>
        + <p>Login to <%site_title%>:</p>
        +
        + <form action="<%config.db_cgi_url%>/user.cgi" method="post">
        +@@ -39,6 +47,14 @@
        +       <input type="password" id="Password" name="Password" class="password" />
        +     </div>
        +   </div>
        ++<%~if config.user_sessions eq Cookies%>
        ++  <div class="row clear">
        ++    <label for="Remember" class="name">Remember Me:</label>
        ++    <div class="value">
        ++      <input type="checkbox" id="Remember" name="Remember" class="checkbox" />
        ++    </div>
        ++  </div>
        ++<%~endif%>
        +   <div class="formsubmit">
        +     <input type="submit" value="Login" class="submit" />
        +   </div>
        +@@ -49,9 +65,11 @@
        +   If you've forgotten your password, we can <a href="<%config.db_cgi_url%>/user.cgi?email_pass=1">e-mail it to you</a>.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: login_email.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login_email.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- login_email.html    11 May 2005 22:35:47 -0000      1.12
        ++++ login_email.html    23 Aug 2006 20:53:31 -0000      1.13
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Forgot your password?</h2>
        +@@ -43,9 +45,11 @@
        +   If you don't have an account, please <a href="<%config.db_cgi_url%>/user.cgi?signup_form=1">register</a>.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: login_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/login_success.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- login_success.html  11 May 2005 22:35:47 -0000      1.10
        ++++ login_success.html  23 Aug 2006 20:53:31 -0000      1.11
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Logged In</h2>
        +@@ -30,9 +32,11 @@
        + </p>
        + <%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: modify.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify.html,v
        +retrieving revision 1.11
        +retrieving revision 1.17
        +diff -u -r1.11 -r1.17
        +--- modify.html 11 May 2005 22:35:47 -0000      1.11
        ++++ modify.html 23 Aug 2006 20:53:31 -0000      1.17
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Modify a Link</h2>
        +@@ -25,9 +27,37 @@
        + <%~if LinkID%>
        +   <input type="hidden" name="LinkID" value="<%escape_html LinkID%>" />
        + <%~else%>
        +-  Please enter the URL of the link you wish to modify. Make sure it is identical to the one already in the database:
        +-  <input type="text" name="Current_URL" value="<%if Current_URL%><%escape_html Current_URL%><%endif%>" class="text" />
        +-  Now enter the new information (all of it, not just the changes) below:
        ++  <noscript>
        ++    <p>
        ++      Please enter the URL of the link you wish to modify. Make sure it is identical to the one already in the database:
        ++    </p>
        ++    <div class="row required clear">
        ++      <label for="Current_URL" class="name">URL: <span>*</span></label>
        ++      <div class="value">
        ++        <input type="text" name="Current_URL" value="<%if Current_URL%><%escape_html Current_URL%><%endif%>" class="text" />
        ++      </div>
        ++    </div>
        ++  </noscript>
        ++  <div id="LinkID" class="row required clear" style="display: none">
        ++    <label class="name">Link: <span>*</span></label>
        ++    <div class="value wrappedtext">
        ++<%~if Current_ID%>
        ++      <input type="hidden" name="Current_ID" value="<%Current_ID%>" />
        ++<%~endif%>
        ++      <script type="text/javascript" src="<%config.build_static_url%>/treecats.js"></script>
        ++      <div id="treecats-links"></div>
        ++      <script type="text/javascript">
        ++        var tcl = new treecats({ selectionMode : 'link', workspace : 'treecats-links', objName : 'tcl', inputName : 'Current_ID', cgiURL : '<%config.db_cgi_url%>', imageURL : '<%config.build_static_url%>/<%t%>/images' });
        ++        tcl.load();
        ++      </script>
        ++    </div>
        ++  </div>
        ++  <script type="text/javascript">
        ++    document.getElementById('LinkID').style.display = '';
        ++  </script>
        ++  <p>
        ++    Enter the new information (all of it, not just the changes) below:
        ++  </p>
        + <%~endif%>
        + <%include include_form.html%>
        +   <div class="formsubmit">
        +@@ -35,9 +65,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: modify_select.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify_select.html,v
        +retrieving revision 1.15
        +retrieving revision 1.17
        +diff -u -r1.15 -r1.17
        +--- modify_select.html  19 Aug 2005 20:07:57 -0000      1.15
        ++++ modify_select.html  23 Aug 2006 20:53:31 -0000      1.17
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Modify a Link</h2>
        +@@ -28,7 +30,7 @@
        +
        + <form action="<%config.db_cgi_url%>/modify.cgi" method="post">
        + <%~loop link_results_loop%>
        +-  <input type="radio" name="LinkID" value="<%escape_html ID%>" class="radio"<%if isValidated eq 'No'%> disabled="disabled"<%endif%> />
        ++  <input type="radio" name="LinkID" value="<%escape_html ID%>" class="radio"<%if isValidated eq No or isExpired or isUnpaid%> disabled="disabled"<%endif%> />
        + <%include link.html%>
        + <%~endloop%>
        +   <input type="submit" value="Modify Link" class="submit" />
        +@@ -36,9 +38,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: modify_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/modify_success.html,v
        +retrieving revision 1.13
        +retrieving revision 1.15
        +diff -u -r1.13 -r1.15
        +--- modify_success.html 4 Jul 2005 23:12:23 -0000       1.13
        ++++ modify_success.html 23 Aug 2006 20:53:31 -0000      1.15
        +@@ -13,15 +13,17 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Link Modified</h2>
        +
        + <p>
        +-<%~if payment_term eq 'free'%>
        ++<%~if payment_term eq free%>
        +   Your link has been changed to a free link:
        + <%~else%>
        +   We have received your request to modify the link as follows:
        +@@ -59,11 +61,13 @@
        +   <div class="value wrappedtext"><%Contact_Email%></div>
        + </div>
        +
        +-<%if payment_term ne 'free'%><p>Thank you! We will send you an e-mail once your link has been validated.</p><%endif%>
        ++<%if not config.user_direct_mod and payment_term ne free%><p>Thank you! We will send you an e-mail once your link has been validated.</p><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: new.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/new.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- new.html    19 Aug 2005 20:07:57 -0000      1.14
        ++++ new.html    23 Aug 2006 20:53:31 -0000      1.15
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>New Links</h2>
        +@@ -50,9 +52,11 @@
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        + <%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: newsletter.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- newsletter.html     11 May 2005 22:35:47 -0000      1.9
        ++++ newsletter.html     23 Aug 2006 20:53:31 -0000      1.10
        +@@ -17,9 +17,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Newsletter</h2>
        +@@ -27,9 +29,11 @@
        + <%if error_message%><p class="errormessage"><%error_message%></p><%endif%>
        + <%if info_message%><p class="infomessage"><%info_message%></p><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: newsletter_browse.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_browse.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- newsletter_browse.html      11 May 2005 22:35:47 -0000      1.15
        ++++ newsletter_browse.html      23 Aug 2006 20:53:31 -0000      1.16
        +@@ -68,9 +68,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Newsletter</h2>
        +@@ -94,9 +96,11 @@
        +   <input type="submit" value="Update Subscriptions" class="submit" />
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: newsletter_global.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_global.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- newsletter_global.html      11 May 2005 22:35:47 -0000      1.9
        ++++ newsletter_global.html      23 Aug 2006 20:53:31 -0000      1.10
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Newsletter</h2>
        +@@ -30,9 +32,11 @@
        +   <input type="submit" value="<%if subscribed%>Unsubscribe<%else%>Subscribe<%endif%>" class="submit" />
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: newsletter_list.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/newsletter_list.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- newsletter_list.html        11 May 2005 22:35:47 -0000      1.15
        ++++ newsletter_list.html        23 Aug 2006 20:53:31 -0000      1.16
        +@@ -20,9 +20,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Newsletter</h2>
        +@@ -49,9 +51,11 @@
        + </p>
        + <%~endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: payment.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- payment.html        11 May 2005 22:35:47 -0000      1.12
        ++++ payment.html        23 Aug 2006 20:53:31 -0000      1.13
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment</h2>
        +@@ -109,9 +111,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: payment_2checkout_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_2checkout_include.html,v
        +retrieving revision 1.3
        +retrieving revision 1.4
        +diff -u -r1.3 -r1.4
        +--- payment_2checkout_include.html      18 Apr 2005 21:39:36 -0000      1.3
        ++++ payment_2checkout_include.html      22 Aug 2006 20:44:01 -0000      1.4
        +@@ -1,6 +1,13 @@
        +-<form action="https://www.2checkout.com/cgi-bin/sbuyers/cartpurchase.2c" method="post">
        ++<form action="https://www.2checkout.com/2co/buyer/purchase" method="post">
        +   <input type="hidden" name="sid" value="<%escape_html seller_id%>" />
        +   <input type="hidden" name="total" value="<%escape_html payment_amount%>" />
        +   <input type="hidden" name="cart_order_id" value="<%escape_html unique_id%>" />
        ++  <input type="hidden" name="fixed" value="Y" />
        ++  <input type="hidden" name="pay_method" value="CC" />
        ++<%~-- This will only work if this matches the domain set up with 2Checkout: https://support.2co.com/deskpro/faq.php?do=article&articleid=363 --%>
        ++  <input type="hidden" name="x_receipt_link_url" value="<%config.db_cgi_url%>/postback.cgi" />
        ++<%~if demo%>
        ++  <input type="hidden" name="demo" value="Y" />
        ++<%~endif%>
        +   <input type="submit" value="Make Payment" class="submit" />
        + </form>
        +Index: payment_direct.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_direct.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- payment_direct.html 11 May 2005 22:35:47 -0000      1.13
        ++++ payment_direct.html 23 Aug 2006 20:53:31 -0000      1.14
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment Confirmation</h2>
        +@@ -27,9 +29,11 @@
        +   <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: payment_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_form.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- payment_form.html   11 May 2005 22:35:47 -0000      1.10
        ++++ payment_form.html   23 Aug 2006 20:53:31 -0000      1.11
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment</h2>
        +@@ -45,9 +47,11 @@
        + <%include payment_manual_include.html%>
        + <%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: payment_method.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_method.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- payment_method.html 11 May 2005 22:35:47 -0000      1.13
        ++++ payment_method.html 23 Aug 2006 20:53:31 -0000      1.14
        +@@ -15,9 +15,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment</h2>
        +@@ -68,9 +70,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: payment_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/payment_success.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- payment_success.html        11 May 2005 22:35:47 -0000      1.13
        ++++ payment_success.html        23 Aug 2006 20:53:31 -0000      1.14
        +@@ -14,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Payment Confirmation</h2>
        +@@ -26,9 +28,11 @@
        +   If this does not happen, click <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: rate.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- rate.html   11 May 2005 22:35:47 -0000      1.13
        ++++ rate.html   23 Aug 2006 20:53:31 -0000      1.14
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Rate a Link</h2>
        +@@ -50,9 +52,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: rate_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate_success.html,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- rate_success.html   11 May 2005 22:35:47 -0000      1.9
        ++++ rate_success.html   23 Aug 2006 20:53:31 -0000      1.10
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Rate a Link</h2>
        +@@ -24,9 +26,11 @@
        +   Thank you for your vote.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: rate_top.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/rate_top.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- rate_top.html       11 May 2005 22:35:47 -0000      1.12
        ++++ rate_top.html       23 Aug 2006 20:53:31 -0000      1.13
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Top Rated Links</h2>
        +@@ -54,9 +56,11 @@
        + <%~endloop%>
        + </table>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: review_add.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add.html,v
        +retrieving revision 1.18
        +retrieving revision 1.19
        +diff -u -r1.18 -r1.19
        +--- review_add.html     11 May 2005 22:35:47 -0000      1.18
        ++++ review_add.html     23 Aug 2006 20:53:31 -0000      1.19
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Add a Review</h2>
        +@@ -76,9 +78,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: review_add_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_add_success.html,v
        +retrieving revision 1.15
        +retrieving revision 1.17
        +diff -u -r1.15 -r1.17
        +--- review_add_success.html     11 May 2005 22:35:47 -0000      1.15
        ++++ review_add_success.html     23 Aug 2006 20:53:31 -0000      1.17
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Review Added</h2>
        +@@ -24,10 +26,12 @@
        +   We have received the following review:
        + </p>
        +
        ++<%~if Review_Rating%>
        + <div class="row clear">
        +   <label class="name">Rating:</label>
        +   <div class="value wrappedtext"><%Review_Rating%></div>
        + </div>
        ++<%~endif%>
        + <div class="row clear">
        +   <label class="name">Subject:</label>
        +   <div class="value wrappedtext"><%Review_Subject%></div>
        +@@ -59,9 +63,11 @@
        + <%~endif%>
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: review_added.eml
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_added.eml,v
        +retrieving revision 1.8
        +retrieving revision 1.9
        +diff -u -r1.8 -r1.9
        +--- review_added.eml    27 Oct 2005 23:25:24 -0000      1.8
        ++++ review_added.eml    15 Aug 2006 00:21:19 -0000      1.9
        +@@ -7,7 +7,9 @@
        + Thank you for visiting our site. We've added the following review into
        + our directory:
        +
        ++<%~if Review_Rating%>
        +     Rating: <%Review_Rating%>
        ++<%~endif%>
        +     Subject: <%Review_Subject%>
        +     By Line: <%Review_ByLine%>
        +     Date: <%Review_Date%>
        +Index: review_edit.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- review_edit.html    11 May 2005 22:35:47 -0000      1.15
        ++++ review_edit.html    23 Aug 2006 20:53:31 -0000      1.16
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Edit Review</h2>
        +@@ -75,9 +77,11 @@
        + <%~endif%>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: review_edit_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_edit_success.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- review_edit_success.html    11 May 2005 22:35:47 -0000      1.11
        ++++ review_edit_success.html    23 Aug 2006 20:53:31 -0000      1.12
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Review Updated</h2>
        +@@ -49,9 +51,11 @@
        + <%~endif%>
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: review_include.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_include.html,v
        +retrieving revision 1.13
        +retrieving revision 1.15
        +diff -u -r1.13 -r1.15
        +--- review_include.html 18 Apr 2005 21:39:36 -0000      1.13
        ++++ review_include.html 27 Jul 2006 04:29:57 -0000      1.15
        +@@ -6,7 +6,7 @@
        +   <%~set ID = ''%>
        + <%~endif%>
        +   <h4 class="reviewsubject">
        +-    <%Review_Subject%><%if Review_Owner eq $user.Username and config.review_allow_modify%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;confirmed=1">edit</a>)</span><%endif%>
        ++    <%Review_Subject%><%if Review_CanModify%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;ReviewID=<%ReviewID%>;confirmed=1">edit</a>)</span><%endif%>
        +     <img src="<%Links::Utils::image_url("stars-5-${Review_Rating}.gif")%>" alt="<%Review_Rating%> out of 5 stars" title="<%Review_Rating%> out of 5 stars" />
        +     <%if Review_IsNew%><span class="new-item"><span>new</span></span><%endif%>
        +   </h4>
        +@@ -16,7 +16,7 @@
        +   </h5>
        + <%~endif%>
        +   <p class="reviewer">
        +-    Reviewed by: <%if Review_GuestName%><a href="mailto:<%Review_GuestEmail%>"><%Review_GuestName%></a><%else%><a href="<%config.db_cgi_url%>/review.cgi?username=<%Review_Owner%>"><%Review_Owner%></a><%endif%>, <%Review_Date%>
        ++    Reviewed by: <%if Review_GuestName%><a href="mailto:<%Review_GuestEmail%>"><%Review_GuestName%></a><%else%><a href="<%config.db_cgi_url%>/review.cgi?username=<%Review_Owner%>"><%Review_Owner%></a><%endif%>, <%Review_Date%><%if Review_ModifyDate%> (Modified: <%Review_ModifyDate%>)<%endif%>
        +   </p>
        + <%~if Review_Contents%>
        +   <div class="reviewcontent">
        +Index: review_search_results.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/review_search_results.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- review_search_results.html  19 Aug 2005 20:07:57 -0000      1.15
        ++++ review_search_results.html  23 Aug 2006 20:53:31 -0000      1.16
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Reviews</h2>
        +@@ -40,9 +42,11 @@
        +
        + <%if ID and not error%><p class="reviewfooter"><a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Add your own Review</a></p><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: search.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/search.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- search.html 11 May 2005 22:35:47 -0000      1.13
        ++++ search.html 23 Aug 2006 20:53:31 -0000      1.14
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Search Form</h2>
        +@@ -54,9 +56,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: search_results.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/search_results.html,v
        +retrieving revision 1.19
        +retrieving revision 1.20
        +diff -u -r1.19 -r1.20
        +--- search_results.html 19 Aug 2005 20:07:57 -0000      1.19
        ++++ search_results.html 23 Aug 2006 20:53:31 -0000      1.20
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Search Results</h2>
        +@@ -51,9 +53,11 @@
        +
        + <%if paging.num_hits%><div class="paging"><%Links::Utils::paging(button_id => 'paging_button2')%></div><%endif%>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: signup_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/signup_form.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- signup_form.html    11 May 2005 22:35:47 -0000      1.15
        ++++ signup_form.html    23 Aug 2006 20:53:31 -0000      1.16
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>User Sign Up</h2>
        +@@ -48,9 +50,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: signup_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/signup_success.html,v
        +retrieving revision 1.11
        +retrieving revision 1.13
        +diff -u -r1.11 -r1.13
        +--- signup_success.html 11 May 2005 22:35:47 -0000      1.11
        ++++ signup_success.html 23 Aug 2006 20:53:31 -0000      1.13
        +@@ -1,4 +1,5 @@
        + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
        ++<%~set message = 'Registration successful'%>
        + <html>
        + <head>
        +   <title><%site_title%>: Successful Sign Up</title>
        +@@ -13,9 +14,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Successful Sign Up</h2>
        +@@ -24,13 +27,15 @@
        + <%~if Validation%>
        +   Thanks for signing up, an e-mail has been sent to you with a validation code. Once you receive it, you'll need to enter a <a href="<%config.db_cgi_url%>/user.cgi?validate=1">validation code</a>
        + <%~else%>
        +-  You have successfully registered.
        ++  You are now logged into <%site_title%> as '<%user.Username%>'.
        + <%~endif%>
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: validate_form.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/validate_form.html,v
        +retrieving revision 1.11
        +retrieving revision 1.12
        +diff -u -r1.11 -r1.12
        +--- validate_form.html  11 May 2005 22:35:47 -0000      1.11
        ++++ validate_form.html  23 Aug 2006 20:53:31 -0000      1.12
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Validation</h2>
        +@@ -37,9 +39,11 @@
        +   </div>
        + </form>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +Index: validate_success.html
        +===================================================================
        +RCS file: /glinks/cgi/admin/templates/luna/validate_success.html,v
        +retrieving revision 1.10
        +retrieving revision 1.11
        +diff -u -r1.10 -r1.11
        +--- validate_success.html       11 May 2005 22:35:47 -0000      1.10
        ++++ validate_success.html       23 Aug 2006 20:53:31 -0000      1.11
        +@@ -13,9 +13,11 @@
        +       <div id="icwrapper" class="clear">
        + <%include include_leftsidebar.html%>
        +         <div id="contentwrapper" class="shadowleft">
        ++<%include include_contentwrapper_top.html%>
        +           <div class="shadowtop"><div class="shadowtopleft"></div><div class="shadowtopright"></div></div>
        +           <div class="shadowright">
        +             <div id="content">
        ++<%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        + <h2>Account Activated</h2>
        +@@ -24,9 +26,11 @@
        +   Thank you, your account is now activated.
        + </p>
        +
        ++<%include include_content_bottom.html%>
        +             </div>
        +           </div>
        +           <div class="shadowbottom"><div class="shadowbottomleft"></div><div class="shadowbottomright"></div></div>
        ++<%include include_contentwrapper_bottom.html%>
        +         </div>
        + <%include include_rightsidebar.html%>
        +       </div>
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.css.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.css.diff.html new file mode 100644 index 0000000..36e00cc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.css.diff.html @@ -0,0 +1,57 @@ + + +Gossamer Links 3.2.0 -> 3.3.0 "luna" template set CSS diff + + + +
        +Index: luna_core.css
        +===================================================================
        +RCS file: glinks/html/static/luna/luna_core.css,v
        +retrieving revision 1.38
        +retrieving revision 1.41
        +diff -u -r1.38 -r1.41
        +--- luna_core.css       11 Aug 2006 04:30:25 -0000      1.38
        ++++ luna_core.css       14 Nov 2007 20:55:40 -0000      1.41
        +@@ -4,7 +4,7 @@
        +  *
        +  *   Website  : http://gossamer-threads.com/
        +  *   Support  : http://gossamer-threads.com/scripts/support/
        +- *   Revision : $Id: 3.2.0-3.3.0.css.diff.html,v 1.2 2009/04/17 00:50:28 brewt Exp $
        ++ *   Revision : $Id: 3.2.0-3.3.0.css.diff.html,v 1.2 2009/04/17 00:50:28 brewt Exp $
        +  *
        +  * Copyright (c) 2005 Gossamer Threads Inc.  All Rights Reserved.
        +  * Redistribution in part or in whole strictly prohibited. Please
        +@@ -122,6 +122,7 @@
        + #logo a {
        +   text-decoration: none;
        +   display: block;
        ++  outline: none;
        + }
        + #header {
        +   background: transparent url(images/swirls.gif) top right no-repeat;
        +@@ -386,6 +387,8 @@
        +   margin: 15px 15px 20px 20px;
        + }
        + .linklisting h4.linktitle, .linklisting p.linkurl, .linklisting p.linkrating {
        ++  overflow: hidden;
        ++  width: 100%;
        +   margin: 2px 0px;
        + }
        + .linklisting h4.linktitle a {
        +@@ -541,6 +544,12 @@
        + #content ul.categories {
        +   margin: 0px;
        + }
        ++#content ul.default {
        ++  margin: 0px 0px 1em 0px;
        ++  padding-left: 3.6em;
        ++  font-size: 11px;
        ++  list-style: disc;
        ++}
        +
        + /* forms */
        + .row {
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.diff.html new file mode 100644 index 0000000..f1e12ac --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/3.2.0-3.3.0.diff.html @@ -0,0 +1,808 @@ + + +Gossamer Links 3.2.0 -> 3.3.0 "luna" template set diff + + + +
        +Index: luna/add_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/add_success.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- luna/add_success.html       23 Aug 2006 20:53:31 -0000      1.15
        ++++ luna/add_success.html       6 Sep 2007 01:36:04 -0000       1.16
        +@@ -46,15 +46,15 @@
        + </div>
        + <div class="row clear">
        +   <label class="name">Description:</label>
        +-  <div class="value wrappedtext"><%Description%></div>
        ++  <div class="value wrappedtext"><%escape_html Description%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Contact Name:</label>
        +-  <div class="value wrappedtext"><%Contact_Name%></div>
        ++  <div class="value wrappedtext"><%escape_html Contact_Name%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Contact E-mail:</label>
        +-  <div class="value wrappedtext"><%Contact_Email%></div>
        ++  <div class="value wrappedtext"><%escape_html Contact_Email%></div>
        + </div>
        +
        + <p>
        +Index: luna/bookmark_folder_view.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/bookmark_folder_view.html,v
        +retrieving revision 1.18
        +retrieving revision 1.19
        +diff -u -r1.18 -r1.19
        +--- luna/bookmark_folder_view.html      23 Aug 2006 20:53:31 -0000      1.18
        ++++ luna/bookmark_folder_view.html      6 Sep 2007 01:36:04 -0000       1.19
        +@@ -2,7 +2,7 @@
        + <%~set secondarynav = "bookmark_nav.html"%>
        + <html>
        + <head>
        +-  <title><%site_title%>: Bookmarks: <%my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></title>
        ++  <title><%site_title%>: Bookmarks: <%escape_html my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></title>
        + <%include include_common_head.html%>
        + </head>
        + <body id="bookmark_folder_view">
        +@@ -21,13 +21,13 @@
        + <%include include_content_top.html%>
        +
        + <div class="crumb"><%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%></div>
        +-<h2><%my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></h2>
        ++<h2><%escape_html my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%></h2>
        +
        + <p>
        + <%~if my_folder_name%>
        +   There <%if link_count != 1%>are<%else%>is<%endif%> <%link_count%> link<%if link_count != 1%>s<%endif%> in this folder.
        + <%~else%>
        +-  <%if my_folder_username eq $user.Username%>You have<%else%><%my_folder_username%> has<%endif%> <%folder_count%> folder<%if folder_count != 1%>s<%endif%> with <%link_count%> link<%if link_count != 1%>s<%endif%>.
        ++  <%if my_folder_username eq $user.Username%>You have<%else%><%escape_html my_folder_username%> has<%endif%> <%folder_count%> folder<%if folder_count != 1%>s<%endif%> with <%link_count%> link<%if link_count != 1%>s<%endif%>.
        + <%~endif%>
        + </p>
        +
        +Index: luna/bookmark_link.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/bookmark_link.html,v
        +retrieving revision 1.4
        +retrieving revision 1.6
        +diff -u -r1.4 -r1.6
        +--- luna/bookmark_link.html     17 Feb 2005 01:28:34 -0000      1.4
        ++++ luna/bookmark_link.html     6 Sep 2007 01:36:04 -0000       1.6
        +@@ -3,8 +3,8 @@
        + <%include link.html%>
        + <%~if editable or my_comment%>
        +   <p class="comments">
        +-    <label><%if my_folder_user_username_fk eq $user.Username%>My<%else%><%my_folder_user_username_fk%>'s<%endif%> Comments
        +-    <%~if editable%> <span>(<a href="<%config.db_cgi_url%>/bookmark.cgi?action=edit_bookmark;id=<%my_link_id_fk%>">edit</a>)</span><%endif~%>
        ++    <label><%if my_folder_user_username_fk eq $user.Username%>My<%else%><%escape_html my_folder_user_username_fk%>'s<%endif%> Comments
        ++    <%~if editable%> <span>(<a href="<%config.db_cgi_url%>/bookmark.cgi?action=edit_bookmark;my_id=<%my_id%>">edit</a>)</span><%endif~%>
        +     :</label> <%if my_comment%><%my_comment%><%else%><em>none</em><%endif%>
        +   </p>
        + <%~endif%>
        +Index: luna/bookmark_link_edit.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/bookmark_link_edit.html,v
        +retrieving revision 1.18
        +retrieving revision 1.19
        +diff -u -r1.18 -r1.19
        +--- luna/bookmark_link_edit.html        23 Aug 2006 20:53:31 -0000      1.18
        ++++ luna/bookmark_link_edit.html        26 Oct 2006 19:44:23 -0000      1.19
        +@@ -33,7 +33,7 @@
        +
        + <form action="<%config.db_cgi_url%>/bookmark.cgi" method="post">
        +   <input type="hidden" name="action" value="edit_bookmark" />
        +-  <input type="hidden" name="id" value="<%escape_html ID%>" />
        ++  <input type="hidden" name="my_id" value="<%escape_html my_id%>" />
        +   <div class="row clear">
        +     <label for="my_comment" class="name">Comments:</label>
        +     <div class="value">
        +@@ -47,7 +47,7 @@
        +       <input type="hidden" name="my_folder_id_fk" value="<%escape_html Folders.0.my_folder_id%>" /><%Folders.0.my_folder_name%>
        +     <%~else%>
        +       <select id="my_folder_id_fk" name="my_folder_id_fk">
        +-        <%loop Folders%><option value="<%escape_html my_folder_id%>"<%if my_folder_default%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        ++        <%loop Folders%><option value="<%escape_html my_folder_id%>"<%if my_folder_id_fk == $my_folder_id%> selected="selected"<%endif%>><%my_folder_name%></option><%endloop%>
        +       </select>
        +     <%~endif%>
        +     </div>
        +Index: luna/bookmark_list.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/bookmark_list.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- luna/bookmark_list.html     23 Aug 2006 20:53:31 -0000      1.17
        ++++ luna/bookmark_list.html     26 Oct 2006 19:44:23 -0000      1.18
        +@@ -54,7 +54,7 @@
        +   <input type="hidden" name="action" value="links_manage" />
        +   <input type="hidden" name="my_folder_id" value="<%escape_html my_folder_id%>" />
        + <%~loop Bookmarks%>
        +-  <input type="checkbox" name="m-id" value="<%escape_html ID%>" class="checkbox" />
        ++  <input type="checkbox" name="my_id" value="<%escape_html my_id%>" class="checkbox" />
        + <%~set editable = 1%>
        + <%include bookmark_link.html%>
        + <%~endloop%>
        +Index: luna/bookmark_users.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/bookmark_users.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/bookmark_users.html    23 Aug 2006 20:53:31 -0000      1.14
        ++++ luna/bookmark_users.html    6 Sep 2007 01:36:04 -0000       1.15
        +@@ -36,7 +36,7 @@
        + <%if users~%>
        + <ul>
        + <%~loop users%>
        +-  <li><a href="<%config.db_cgi_url%>/bookmark.cgi?action=users_folder;my_folder_username=<%my_folder_user_username_fk%>"><%my_folder_user_username_fk%></a> (<%public_folders%> folder<%if public_folders != 1%>s<%endif%> with <%public_links%> link<%if public_links != 1%>s<%endif%>)</li>
        ++  <li><a href="<%config.db_cgi_url%>/bookmark.cgi?action=users_folder;my_folder_username=<%escape_url my_folder_user_username_fk%>"><%escape_html my_folder_user_username_fk%></a> (<%public_folders%> folder<%if public_folders != 1%>s<%endif%> with <%public_links%> link<%if public_links != 1%>s<%endif%>)</li>
        + <%~endloop%>
        + </ul>
        + <%~endif%>
        +Index: luna/category.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/category.html,v
        +retrieving revision 1.31
        +retrieving revision 1.32
        +diff -u -r1.31 -r1.32
        +--- luna/category.html  23 Aug 2006 20:53:31 -0000      1.31
        ++++ luna/category.html  6 Sep 2007 01:36:04 -0000       1.32
        +@@ -66,7 +66,7 @@
        + <h3>Editors</h3>
        + <ul>
        + <%~loop editors_loop%>
        +-  <li><%Username%></li>
        ++  <li><%escape_html Username%></li>
        + <%~endloop%>
        + </ul>
        + <%~endif%>
        +Index: luna/detailed.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/detailed.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- luna/detailed.html  23 Aug 2006 20:53:31 -0000      1.17
        ++++ luna/detailed.html  6 Sep 2007 01:36:04 -0000       1.18
        +@@ -46,7 +46,7 @@
        + <%if Description%><p class="description"><%Description%></p><%endif%>
        +
        + <p class="info">
        +-  Submitted by: <%LinkOwner%><br />
        ++  Submitted by: <%escape_html LinkOwner%><br />
        +   Hits: <%Hits%><br />
        +   Added: <%Add_Date%><br />
        +   <%if Add_Date ne $Mod_Date%>Last Modified: <%Mod_Date%><br /><%endif%>
        +Index: luna/include_form.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/include_form.html,v
        +retrieving revision 1.14
        +retrieving revision 1.16
        +diff -u -r1.14 -r1.16
        +--- luna/include_form.html      19 Aug 2006 03:23:10 -0000      1.14
        ++++ luna/include_form.html      15 Nov 2007 01:41:26 -0000      1.16
        +@@ -11,7 +11,7 @@
        +   </div>
        + </div>
        + <div class="row<%unless category_loop_selected%> required<%endunless%> clear">
        +-  <label for="CatLinks.CategoryID" class="name">Category:<%unless category_loop_selected%> <span>*</span><%endunless%></label>
        ++  <label class="name">Category:<%unless category_loop_selected%> <span>*</span><%endunless%></label>
        +   <div class="value wrappedtext">
        +   <%~if config.db_gen_category_list == 2%>
        +     <script type="text/javascript" src="<%config.build_static_url%>/treecats.js"></script>
        +@@ -31,7 +31,7 @@
        +     </noscript>
        +     <div id="treecats"></div>
        +     <script type="text/javascript">
        +-      var tc = new treecats({ <%-- selectionMode : 'multiple', --%> cgiURL : '<%config.db_cgi_url%>', imageURL : '<%config.build_static_url%>/<%t%>/images' });
        ++      var tc = new treecats({ <%-- selectionMode : 'multiple', --%> cgiURL : '<%config.db_cgi_url%>', cgiQueryString : '<%url_hidden%>', imageURL : '<%config.build_static_url%>/<%t%>/images' });
        +       tc.load();
        +     </script>
        +   <%~elsif category_loop_selected%>
        +Index: luna/include_header.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/include_header.html,v
        +retrieving revision 1.12
        +retrieving revision 1.14
        +diff -u -r1.12 -r1.14
        +--- luna/include_header.html    18 Apr 2005 21:39:36 -0000      1.12
        ++++ luna/include_header.html    19 Dec 2007 07:06:36 -0000      1.14
        +@@ -1,15 +1,15 @@
        + <div id="header">
        +   <div id="loginbar"><a href="<%config.db_cgi_url%>/user.cgi<%if user.Username%>?logout=1<%endif%>" class="<%if user.Username%>in<%else%>out<%endif%>"><%if user.Username%>Logout<%else%>Login/Register<%endif%></a></div>
        +-  <div id="logo"><h1><a href="<%config.build_root_url%>"><%site_title%></a></h1></div>
        ++  <div id="logo"><h1><a href="<%config.build_root_url%>/<%home_index%>"><%site_title%></a></h1></div>
        + </div>
        + <div class="navbar clear">
        +   <ul class="primarynav">
        +-    <li class="home"><a href="<%config.build_root_url%>">Home</a></li>
        ++    <li class="home"><a href="<%config.build_root_url%>/<%home_index%>">Home</a></li>
        +     <li><a href="<%config.db_cgi_url%>/add.cgi<%if category_id%>?ID=<%category_id%><%endif%>">Add a Link</a></li>
        +     <li><a href="<%config.db_cgi_url%>/modify.cgi<%if category_id%>?ID=<%category_id%><%endif%>">Modify a Link</a></li>
        +-    <li><a href="<%config.build_root_url%>/New/">New Links</a></li>
        +-    <li><a href="<%config.build_root_url%>/Cool/">Cool Links</a></li>
        +-    <li><a href="<%config.build_root_url%>/Ratings/">Top Rated</a></li>
        ++    <li><a href="<%config.build_new_url%>/">New Links</a></li>
        ++    <li><a href="<%config.build_cool_url%>/">Cool Links</a></li>
        ++    <li><a href="<%config.build_ratings_url%>/">Top Rated</a></li>
        +     <li><a href="<%config.db_cgi_url%>/jump.cgi?ID=random<%if config.build_detailed%>;Detailed=1<%endif%>">Random Link</a></li>
        +     <%if config.newsletter_enabled%><li><a href="<%config.db_cgi_url%>/subscribe.cgi">Newsletter</a></li><%endif%>
        +     <%if config.bookmark_enabled%><li><a href="<%config.db_cgi_url%>/bookmark.cgi">Bookmarks</a></li><%endif%>
        +Index: luna/jump.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/jump.html,v
        +retrieving revision 1.2
        +retrieving revision 1.3
        +diff -u -r1.2 -r1.3
        +--- luna/jump.html      25 Feb 2005 06:05:50 -0000      1.2
        ++++ luna/jump.html      6 Sep 2007 01:36:04 -0000       1.3
        +@@ -4,7 +4,7 @@
        +   <title><%site_title%>: <%Title%></title>
        + </head>
        + <frameset id="jump" rows="40,*">
        +-  <frame src="<%config.db_cgi_url%>/jump.cgi?action=jump_frame;ID=<%ID%>" scrolling="no" noresize="noresize" />
        ++  <frame src="<%config.db_cgi_url%>/jump.cgi?action=jump_frame;ID=<%escape_html ID%>" scrolling="no" noresize="noresize" />
        +   <frame src="<%destination%>" />
        +   <noframes>
        +     <body>
        +Index: luna/jump_frame.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/jump_frame.html,v
        +retrieving revision 1.7
        +retrieving revision 1.8
        +diff -u -r1.7 -r1.8
        +--- luna/jump_frame.html        4 Jul 2005 23:12:23 -0000       1.7
        ++++ luna/jump_frame.html        19 Dec 2007 07:06:36 -0000      1.8
        +@@ -7,7 +7,7 @@
        + </head>
        + <body id="jump_frame">
        +   <div class="jumpwrapper">
        +-    <a href="<%config.build_root_url%>"><img src="<%Links::Utils::image_url('logo-small.gif')%>" class="jumplogo" alt="<%site_title%>" /></a>
        ++    <a href="<%config.build_root_url%>/<%home_index%>"><img src="<%Links::Utils::image_url('logo-small.gif')%>" class="jumplogo" alt="<%site_title%>" /></a>
        +
        +   <%if error%>
        +     <p class="errormessage">
        +Index: luna/link_added.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/link_added.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.8
        +diff -u -r1.6 -r1.8
        +--- luna/link_added.eml 27 Oct 2005 23:25:24 -0000      1.6
        ++++ luna/link_added.eml 19 Dec 2007 07:06:36 -0000      1.8
        +@@ -16,13 +16,13 @@
        +
        + You can see your new listing at:
        +
        +-    <%config.build_root_url%>
        ++    <%config.build_root_url%>/<%home_index%>
        +
        + Should you have any questions, please don't hesitate to ask.
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : link_added.eml
        +Index: luna/link_expired.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/link_expired.eml,v
        +retrieving revision 1.7
        +retrieving revision 1.8
        +diff -u -r1.7 -r1.8
        +--- luna/link_expired.eml       27 Oct 2005 23:25:24 -0000      1.7
        ++++ luna/link_expired.eml       26 Aug 2006 03:22:15 -0000      1.8
        +@@ -15,7 +15,7 @@
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : link_expired.eml
        +Index: luna/link_expiry_notify.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/link_expiry_notify.eml,v
        +retrieving revision 1.8
        +retrieving revision 1.9
        +diff -u -r1.8 -r1.9
        +--- luna/link_expiry_notify.eml 27 Oct 2005 23:25:24 -0000      1.8
        ++++ luna/link_expiry_notify.eml 26 Aug 2006 03:22:15 -0000      1.9
        +@@ -15,7 +15,7 @@
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : link_expiry_notify.eml
        +Index: luna/link_modified.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/link_modified.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.8
        +diff -u -r1.6 -r1.8
        +--- luna/link_modified.eml      27 Oct 2005 23:25:24 -0000      1.6
        ++++ luna/link_modified.eml      19 Dec 2007 07:06:36 -0000      1.8
        +@@ -16,13 +16,13 @@
        +
        + You can see your updated listing at:
        +
        +-    <%config.build_root_url%>
        +-  
        ++    <%config.build_root_url%>/<%home_index%>
        ++
        + Should you have any questions, please don't hesitate to ask.
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : link_modified.eml
        +Index: luna/link_rejected.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/link_rejected.eml,v
        +retrieving revision 1.4
        +retrieving revision 1.5
        +diff -u -r1.4 -r1.5
        +--- luna/link_rejected.eml      27 Oct 2005 23:25:24 -0000      1.4
        ++++ luna/link_rejected.eml      26 Aug 2006 03:22:15 -0000      1.5
        +@@ -16,7 +16,7 @@
        +
        + If you have any questions, please don't hesitate to ask.
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : link_rejected.eml
        +Index: luna/login.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/login.html,v
        +retrieving revision 1.21
        +retrieving revision 1.24
        +diff -u -r1.21 -r1.24
        +--- luna/login.html     23 Aug 2006 20:53:31 -0000      1.21
        ++++ luna/login.html     5 Jan 2009 21:19:34 -0000       1.24
        +@@ -1,7 +1,10 @@
        + <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
        +-<%~if logout and error%>
        +-  <%~set message = $error%>
        +-  <%~set error = ''%>
        ++<%~if error%>
        ++  <%~-- Move $error into $message.  Done for backwards compatibility with Links SQL 2.x templates. --%>
        ++  <%~if logout or send_pass or send_validate%>
        ++    <%~set message = $error%>
        ++    <%~set error = ''%>
        ++  <%~endif%>
        + <%~endif%>
        + <%~if url and not error%>
        +   <%~set error = 'You must first login before you can access that.'%>
        +@@ -51,7 +54,7 @@
        +   <div class="row clear">
        +     <label for="Remember" class="name">Remember Me:</label>
        +     <div class="value">
        +-      <input type="checkbox" id="Remember" name="Remember" class="checkbox" />
        ++      <input type="checkbox" id="Remember" name="Remember"<%if Remember%> checked="checked"<%endif%> class="checkbox" />
        +     </div>
        +   </div>
        + <%~endif%>
        +@@ -62,7 +65,9 @@
        +
        + <p>
        +   If you don't have an account, please <a href="<%config.db_cgi_url%>/user.cgi?signup_form=1">register</a>.<br />
        ++<%~if config.user_allow_pass%>
        +   If you've forgotten your password, we can <a href="<%config.db_cgi_url%>/user.cgi?email_pass=1">e-mail it to you</a>.
        ++<%~endif%>
        + </p>
        +
        + <%include include_content_bottom.html%>
        +Index: luna/modify.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/modify.html,v
        +retrieving revision 1.17
        +retrieving revision 1.20
        +diff -u -r1.17 -r1.20
        +--- luna/modify.html    23 Aug 2006 20:53:31 -0000      1.17
        ++++ luna/modify.html    6 Sep 2007 01:36:04 -0000       1.20
        +@@ -26,8 +26,11 @@
        +   <input type="hidden" name="modify" value="1" />
        + <%~if LinkID%>
        +   <input type="hidden" name="LinkID" value="<%escape_html LinkID%>" />
        ++  <input type="hidden" name="Current_ID" value="<%escape_html LinkID%>" />
        + <%~else%>
        ++  <%~if config.db_gen_category_list == 2%>
        +   <noscript>
        ++  <%~endif%>
        +     <p>
        +       Please enter the URL of the link you wish to modify. Make sure it is identical to the one already in the database:
        +     </p>
        +@@ -37,13 +40,14 @@
        +         <input type="text" name="Current_URL" value="<%if Current_URL%><%escape_html Current_URL%><%endif%>" class="text" />
        +       </div>
        +     </div>
        ++  <%~if config.db_gen_category_list == 2%>
        +   </noscript>
        +   <div id="LinkID" class="row required clear" style="display: none">
        +     <label class="name">Link: <span>*</span></label>
        +     <div class="value wrappedtext">
        +-<%~if Current_ID%>
        +-      <input type="hidden" name="Current_ID" value="<%Current_ID%>" />
        +-<%~endif%>
        ++    <%~if Current_ID%>
        ++      <input type="hidden" name="Current_ID" value="<%escape_html Current_ID%>" />
        ++    <%~endif%>
        +       <script type="text/javascript" src="<%config.build_static_url%>/treecats.js"></script>
        +       <div id="treecats-links"></div>
        +       <script type="text/javascript">
        +@@ -55,6 +59,7 @@
        +   <script type="text/javascript">
        +     document.getElementById('LinkID').style.display = '';
        +   </script>
        ++  <%~endif%>
        +   <p>
        +     Enter the new information (all of it, not just the changes) below:
        +   </p>
        +Index: luna/modify_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/modify_success.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- luna/modify_success.html    23 Aug 2006 20:53:31 -0000      1.15
        ++++ luna/modify_success.html    6 Sep 2007 01:36:04 -0000       1.16
        +@@ -50,15 +50,15 @@
        + </div>
        + <div class="row clear">
        +   <label class="name">Description:</label>
        +-  <div class="value wrappedtext"><%Description%></div>
        ++  <div class="value wrappedtext"><%escape_html Description%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Contact Name:</label>
        +-  <div class="value wrappedtext"><%Contact_Name%></div>
        ++  <div class="value wrappedtext"><%escape_html Contact_Name%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Contact E-mail:</label>
        +-  <div class="value wrappedtext"><%Contact_Email%></div>
        ++  <div class="value wrappedtext"><%escape_html Contact_Email%></div>
        + </div>
        +
        + <%if not config.user_direct_mod and payment_term ne free%><p>Thank you! We will send you an e-mail once your link has been validated.</p><%endif%>
        +Index: luna/newsletter_list.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/newsletter_list.html,v
        +retrieving revision 1.16
        +retrieving revision 1.17
        +diff -u -r1.16 -r1.17
        +--- luna/newsletter_list.html   23 Aug 2006 20:53:31 -0000      1.16
        ++++ luna/newsletter_list.html   6 Sep 2007 01:36:04 -0000       1.17
        +@@ -41,7 +41,7 @@
        +   <input type="hidden" name="page" value="newsletter_list" />
        +   <%if subscribed.length > 1%><input type="checkbox" id="checkall" class="checkbox" /> <label for="checkall"><strong>Select All</strong></label><br /><%endif%>
        + <%loop subscribed~%>
        +-  <input type="checkbox" id="ID-<%CategoryID%>" name="ID" value="<%escape_html CategoryID%>" class="checkbox" /> <label for="ID-<%CategoryID%>"><%Full_Name%></label><br />
        ++  <input type="checkbox" id="ID-<%escape_html CategoryID%>" name="ID" value="<%escape_html CategoryID%>" class="checkbox" /> <label for="ID-<%escape_html CategoryID%>"><%Full_Name%></label><br />
        + <%~endloop%>
        +   <input type="submit" value="Unsubscribe" class="submit" />
        + </form>
        +Index: luna/password.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/password.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/password.eml   27 Oct 2005 23:25:24 -0000      1.5
        ++++ luna/password.eml   26 Aug 2006 03:22:15 -0000      1.6
        +@@ -14,7 +14,7 @@
        +
        + Hope that helps,
        +
        +-Link Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : password.eml
        +Index: luna/payment_direct.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/payment_direct.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/payment_direct.html    23 Aug 2006 20:53:31 -0000      1.14
        ++++ luna/payment_direct.html    19 Dec 2007 07:05:20 -0000      1.15
        +@@ -2,7 +2,7 @@
        + <html>
        + <head>
        +   <title><%site_title%>: Payment Confirmation</title>
        +-  <meta http-equiv="refresh" content="5;url=<%Links::transform_url($config.build_root_url, '', '&')%>" />
        ++  <meta http-equiv="refresh" content="5;url=<%Links::transform_url("${config.build_root_url}$home_index", '', '&')%>" />
        + <%include include_common_head.html%>
        + </head>
        + <body id="payment_direct">
        +@@ -26,7 +26,7 @@
        + <p>
        +   Your payment has been approved, and your link enabled.  You will be redirected
        +   to the main page shortly.  If this does not happen, click
        +-  <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++  <a href="<%config.build_root_url%>/<%build_index%>">here</a>.
        + </p>
        +
        + <%include include_content_bottom.html%>
        +Index: luna/payment_manual_include.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/payment_manual_include.html,v
        +retrieving revision 1.3
        +retrieving revision 1.5
        +diff -u -r1.3 -r1.5
        +--- luna/payment_manual_include.html    4 Mar 2005 00:45:17 -0000       1.3
        ++++ luna/payment_manual_include.html    19 Dec 2007 07:06:36 -0000      1.5
        +@@ -6,7 +6,7 @@
        +   with your payment:
        + </p>
        + <p>
        +-  Link ID: <%ID%><br />
        +-  Payment ID: <%unique_id%>
        ++  Link ID: <%escape_html ID%><br />
        ++  Payment ID: <%escape_html unique_id%>
        + </p>
        +-<input type="button" value="Done" onclick="window.location='<%Links::transform_url($config.build_root_url)%>'" />
        ++<input type="button" value="Done" onclick="window.location='<%Links::transform_url("${config.build_root_url}$home_index")%>'" />
        +Index: luna/payment_received.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/payment_received.eml,v
        +retrieving revision 1.6
        +retrieving revision 1.8
        +diff -u -r1.6 -r1.8
        +--- luna/payment_received.eml   27 Oct 2005 23:25:24 -0000      1.6
        ++++ luna/payment_received.eml   19 Dec 2007 07:06:36 -0000      1.8
        +@@ -16,13 +16,13 @@
        +
        + You can see your new listing at:
        +
        +-    <%config.build_root_url%>
        ++    <%config.build_root_url%>/<%home_index%>
        +
        + Should you have any questions, please don't hesitate to ask.
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : payment_received.eml
        +Index: luna/payment_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/payment_success.html,v
        +retrieving revision 1.14
        +retrieving revision 1.15
        +diff -u -r1.14 -r1.15
        +--- luna/payment_success.html   23 Aug 2006 20:53:31 -0000      1.14
        ++++ luna/payment_success.html   19 Dec 2007 07:05:20 -0000      1.15
        +@@ -2,7 +2,7 @@
        + <html>
        + <head>
        +   <title><%site_title%>: Payment Confirmation</title>
        +-  <meta http-equiv="refresh" content="5;url=<%Links::transform_url($config.build_root_url, '', '&')%>" />
        ++  <meta http-equiv="refresh" content="5;url=<%Links::transform_url("${config.build_root_url}$home_index", '', '&')%>" />
        + <%include include_common_head.html%>
        + </head>
        + <body id="payment_success">
        +@@ -25,7 +25,7 @@
        +
        + <p>
        +   Your payment has been approved.  You will be redirected to the main page shortly.
        +-  If this does not happen, click <a href="<%Links::transform_url($config.build_root_url)%>">here</a>.
        ++  If this does not happen, click <a href="<%config.build_root_url%>/<%home_index%>">here</a>.
        + </p>
        +
        + <%include include_content_bottom.html%>
        +Index: luna/review_add_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/review_add_success.html,v
        +retrieving revision 1.17
        +retrieving revision 1.18
        +diff -u -r1.17 -r1.18
        +--- luna/review_add_success.html        23 Aug 2006 20:53:31 -0000      1.17
        ++++ luna/review_add_success.html        6 Sep 2007 01:36:04 -0000       1.18
        +@@ -29,29 +29,29 @@
        + <%~if Review_Rating%>
        + <div class="row clear">
        +   <label class="name">Rating:</label>
        +-  <div class="value wrappedtext"><%Review_Rating%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_Rating%></div>
        + </div>
        + <%~endif%>
        + <div class="row clear">
        +   <label class="name">Subject:</label>
        +-  <div class="value wrappedtext"><%Review_Subject%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_Subject%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">By Line:</label>
        +-  <div class="value wrappedtext"><%Review_ByLine%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_ByLine%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Review:</label>
        +-  <div class="value wrappedtext"><%Review_Contents%></div>
        ++  <div class="value wrappedtext"><%if config.review_convert_br_tags%><%Review_Contents%><%else%><%escape_html Review_Contents%><%endif%></div>
        + </div>
        + <%~if not config.user_review_required and not user.Username%>
        + <div class="row clear">
        +   <label class="name">Name:</label>
        +-  <div class="value wrappedtext"><%Review_GuestName%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_GuestName%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">E-mail:</label>
        +-  <div class="value wrappedtext"><%Review_GuestEmail%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_GuestEmail%></div>
        + </div>
        + <%~endif%>
        +
        +Index: luna/review_added.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/review_added.eml,v
        +retrieving revision 1.9
        +retrieving revision 1.10
        +diff -u -r1.9 -r1.10
        +--- luna/review_added.eml       15 Aug 2006 00:21:19 -0000      1.9
        ++++ luna/review_added.eml       26 Aug 2006 03:22:15 -0000      1.10
        +@@ -27,7 +27,7 @@
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : review_added.eml
        +Index: luna/review_edit_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/review_edit_success.html,v
        +retrieving revision 1.12
        +retrieving revision 1.13
        +diff -u -r1.12 -r1.13
        +--- luna/review_edit_success.html       23 Aug 2006 20:53:31 -0000      1.12
        ++++ luna/review_edit_success.html       6 Sep 2007 01:36:04 -0000       1.13
        +@@ -26,21 +26,23 @@
        +   We have received the following review:
        + </p>
        +
        ++<%~if Review_Rating%>
        + <div class="row clear">
        +   <label class="name">Rating:</label>
        +-  <div class="value wrappedtext"><%Review_Rating%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_Rating%></div>
        + </div>
        ++<%~endif%>
        + <div class="row clear">
        +   <label class="name">Subject:</label>
        +-  <div class="value wrappedtext"><%Review_Subject%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_Subject%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">By Line:</label>
        +-  <div class="value wrappedtext"><%Review_ByLine%></div>
        ++  <div class="value wrappedtext"><%escape_html Review_ByLine%></div>
        + </div>
        + <div class="row clear">
        +   <label class="name">Review:</label>
        +-  <div class="value wrappedtext"><%Review_Contents%></div>
        ++  <div class="value wrappedtext"><%if config.review_convert_br_tags%><%Review_Contents%><%else%><%escape_html Review_Contents%><%endif%></div>
        + </div>
        +
        + <p>
        +Index: luna/review_include.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/review_include.html,v
        +retrieving revision 1.15
        +retrieving revision 1.16
        +diff -u -r1.15 -r1.16
        +--- luna/review_include.html    27 Jul 2006 04:29:57 -0000      1.15
        ++++ luna/review_include.html    6 Sep 2007 01:36:04 -0000       1.16
        +@@ -6,13 +6,13 @@
        +   <%~set ID = ''%>
        + <%~endif%>
        +   <h4 class="reviewsubject">
        +-    <%Review_Subject%><%if Review_CanModify%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;ReviewID=<%ReviewID%>;confirmed=1">edit</a>)</span><%endif%>
        ++    <%escape_html Review_Subject%><%if Review_CanModify%> <span class="hsmall">(<a href="<%config.db_cgi_url%>/review.cgi?edit_review=1;ID=<%Review_LinkID%>;ReviewID=<%ReviewID%>;confirmed=1">edit</a>)</span><%endif%>
        +     <img src="<%Links::Utils::image_url("stars-5-${Review_Rating}.gif")%>" alt="<%Review_Rating%> out of 5 stars" title="<%Review_Rating%> out of 5 stars" />
        +     <%if Review_IsNew%><span class="new-item"><span>new</span></span><%endif%>
        +   </h4>
        + <%~if Review_ByLine%>
        +   <h5 class="reviewbyline">
        +-    <%Review_ByLine%>
        ++    <%escape_html Review_ByLine%>
        +   </h5>
        + <%~endif%>
        +   <p class="reviewer">
        +@@ -20,7 +20,11 @@
        +   </p>
        + <%~if Review_Contents%>
        +   <div class="reviewcontent">
        ++  <%~if config.review_convert_br_tags%>
        +     <%Review_Contents%>
        ++  <%~else%>
        ++    <%escape_html Review_Contents%>
        ++  <%~endif%>
        +   </div>
        + <%~endif%>
        +   <div class="reviewhelpful clear">
        +Index: luna/review_rejected.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/review_rejected.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/review_rejected.eml    27 Oct 2005 23:25:24 -0000      1.5
        ++++ luna/review_rejected.eml    26 Aug 2006 03:22:15 -0000      1.6
        +@@ -19,7 +19,7 @@
        +
        + If you have any questions, please don't hesitate to ask.
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : review_rejected.eml
        +Index: luna/signup_success.html
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/signup_success.html,v
        +retrieving revision 1.13
        +retrieving revision 1.14
        +diff -u -r1.13 -r1.14
        +--- luna/signup_success.html    23 Aug 2006 20:53:31 -0000      1.13
        ++++ luna/signup_success.html    6 Sep 2007 01:36:04 -0000       1.14
        +@@ -27,7 +27,7 @@
        + <%~if Validation%>
        +   Thanks for signing up, an e-mail has been sent to you with a validation code. Once you receive it, you'll need to enter a <a href="<%config.db_cgi_url%>/user.cgi?validate=1">validation code</a>
        + <%~else%>
        +-  You are now logged into <%site_title%> as '<%user.Username%>'.
        ++  You are now logged into <%site_title%> as '<%escape_html user.Username%>'.
        + <%~endif%>
        + </p>
        +
        +Index: luna/validate.eml
        +===================================================================
        +RCS file: glinks/cgi/admin/templates/luna/validate.eml,v
        +retrieving revision 1.5
        +retrieving revision 1.6
        +diff -u -r1.5 -r1.6
        +--- luna/validate.eml   27 Oct 2005 23:25:24 -0000      1.5
        ++++ luna/validate.eml   26 Aug 2006 03:22:15 -0000      1.6
        +@@ -7,7 +7,7 @@
        + Thank you for registering. To activate your account, simply go to:
        +
        +     <%config.db_cgi_url%>/user.cgi?validate=1
        +-    
        ++
        + and enter the following code:
        +
        +     <%Validation%>
        +@@ -16,7 +16,7 @@
        +
        + Sincerely,
        +
        +-Links Manager
        ++<%site_title%>
        +
        + <%~--
        +         File        : validate.eml
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/README b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/README new file mode 100644 index 0000000..2b98409 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/README @@ -0,0 +1,2 @@ +These are admin templates and control the look and feel of your admin panel. You should not normally need to change these. + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_actions.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_actions.html new file mode 100644 index 0000000..5d47495 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_actions.html @@ -0,0 +1,10 @@ +
        + Show Position + + #<%ID%>: + Edit + <%~if not no_links%> + | Delete + <%~endif%> + +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_automated.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_automated.html new file mode 100644 index 0000000..0ef6757 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_automated.html @@ -0,0 +1,39 @@ +
        + <%~if Widget eq 'poll'%> +
        + <%~elsif Widget eq 'feature_threads'%> + <%include ../twitch/_widget_threads.html%> + <%~else%> +
        + <%if Widget eq 'collapse'%> + style="<%TitleStyle%>"<%endif%> class="lnk"><%Title%> +
        + <%~if Subtitle%><%Subtitle%><%endif%> + <%if Image%><%if URL%><%endif%><%if URL%><%endif%><%endif%> + <%if Button%>
        <%endif%> +
        + <%else%> + style="<%TitleStyle%>"<%endif%>><%Title%>

        + <%~if Subtitle%>
        <%Subtitle%>
        <%endif%> + <%~if Widget eq 'newsletter'%> + <%include ../twitch/_widget_newsletter.html%> + <%~elsif Widget eq 'calculators'%> + <%include ../twitch/_widget_calculators.html%> + <%~elsif Widget eq 'local_listings'%> + <%include ../twitch/_widget_local_listings.html%> + <%~elsif Widget eq 'category_list'%> + <%include ../twitch/_widget_category_list.html%> + <%~elsif Widget eq 'editors_pick'%> + <%include ../twitch/_widget_editors_pick.html%> + <%~elsif Widget eq 'feature_article'%> + <%include ../twitch/_widget_feature_article.html%> + <%elsif Widget eq 'most_popular'%> + <%include ../twitch/_widget_most_popular.html%> + <%elsif Widget eq 'external'%> + <%include ../twitch/_widget_external.html%> + <%~endif%> + <%endif%> + + <%~endif%> + <%include _widget_actions.html%> + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_manual.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_manual.html new file mode 100644 index 0000000..d2beac6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_manual.html @@ -0,0 +1,9 @@ +
        +
        + <%if Title%> style="<%TitleStyle%>"<%endif%>><%Title%><%endif%> + <%if Subtitle%>
        <%Subtitle%>
        <%endif%> + <%if Image%><%if URL%><%endif%><%if URL%><%endif%><%endif%> + <%if Button%>
        <%endif%> +
        + <%include _widget_actions.html%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_pages.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_pages.html new file mode 100644 index 0000000..e7c5bd7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/_widget_pages.html @@ -0,0 +1,17 @@ +
        +

        This widget will appear on: <%pages.length || 0%> page(s)

        + <%~if pages.length%> + + <%~endif%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build.html new file mode 100644 index 0000000..abbc0dd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build.html @@ -0,0 +1,19 @@ + + + +Gossamer Links - Build + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_css.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_css.html new file mode 100644 index 0000000..3429d17 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_css.html @@ -0,0 +1,128 @@ +<%Links::Tools::editor_size%> +<%set font_tag = ''%> + + + Gossamer Links - Build - CSS Editor + + +<%if not css_dir or css_dir contains '..' or css_dir contains '/' or css_dir contains '\\'%> + <%set css_dir = Links::template_set%> +<%endif%> + +<%set demo = 0%> +<%set setcookie = 'set-cookie'%> +<%if action eq 'load'%> + <%Links::Tools::css_editor( + action => 'load', + css_dir => $css_dir, + css_file => $css_file + )%> + <%if error%> + <%set error_message = "Unable to load CSS: $error"%> + <%else%> + <%set displaying_css = 1%> + <%endif%> +<%elsif action eq 'save'%> + <%if save_as%> + <%set css_file = $save_as%> + <%endif%> + <%if css_file ne 'luna_core.css'%> + <%Links::Tools::css_editor( + action => 'save', + css_dir => $css_dir, + css_file => $css_file, + css => $css, + demo => $demo + )%> + <%else%> + <%set error = "You should not be modifying this file, please save your changes in the luna.css file."%> + <%endif%> + <%if error%> + <%set error_message = "Unable to save CSS: $error"%> + <%set displaying_css = 1%> + <%else%> + <%set success_message = "CSS file saved sucessfully"%> + <%Links::Tools::css_editor( + action => 'load', + css_dir => $css_dir, + css_file => $css_file + )%> + <%if error%> + <%set error_message = "Unable to load CSS: $error"%> + <%else%> + <%set displaying_css = 1%> + <%endif%> + <%endif%> +<%elsif action eq 'delete'%> + <%Links::Tools::css_editor( + action => 'delete', + css_dir => $css_dir, + css_file => $css_file, + demo => $demo + )%> + <%if error%> + <%set error_message = "Unable to delete CSS: $error"%> + <%else%> + <%set success_message = "CSS deleted successfully"%> + <%endif%> +<%elsif in.$setcookie%> + <%set displaying_css = 1%> +<%endif%> +<%set css_dir_exists = 0%> +<%Links::Tools::file_select($config.build_static_path, '(?:\.\.?|CVS|admin|browser|fileman)', '', 'd')%> +<%if not file_loop.length%> + <%set error_message = "Could not find CSS files. Perhaps your build_static_path is incorrect?"%> +<%endif%> + + + + + +
        + + + + + + + +
        + <%font_tag%>CSS Editor +
        +

        <%font_tag%>CSS Editor

        +

        <%font_tag%>From here you can quickly edit the CSS files for your templates. + <%if success_message%>

        <%font_tag%><%success_message%>

        <%endif%> + <%if error_message%>

        <%font_tag%><%error_message%>

        <%endif%> +
        +
        +
        +
        + + + +<%if file_loop.length%> + + + + +
        + + + + +
        +

        <%font_tag%>Template set:

        +<%unless css_dir_exists%><%set css_dir = $file_loop.0%><%endunless%> +<%Links::Tools::file_select("${config.build_static_path}/$css_dir", '', '.*\.css', 'f')%> +

        <%font_tag%>CSS files:

        + +
        +

        <%font_tag%>Save file as:

        +

        <%font_tag%>Resize Textarea to: rows, columns

        +
        +
        +<%endif%> +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_email.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_email.html new file mode 100644 index 0000000..bd00f82 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_email.html @@ -0,0 +1,208 @@ +<%Links::Tools::editor_size%> +<%set font_tag = ''%> + + + Gossamer Links - Build - Email Templates + + +<%set template_root = $config.admin_root_path%> +<%set template_root .= "/templates"%> +<%set setcookie = 'set-cookie'%> +<%if save_template%> + <%if save_as%> + <%set template_file = $save_as%> + <%set tpl_file = $save_as%> + <%else%> + <%set template_file = $tpl_file%> + <%endif%> + + <%GT::Mail::Editor::tpl_save( + dir => $template_root, + template => $tpl_dir, + file => $template_file, + header => To => $header_To, + header => Subject => $header_Subject, + header => From => $header_From, + extra_headers => $extra_headers, + body => $body + )%> + <%if error%> + <%set error_message = "Unable to save template: $error"%> + <%set display_template = 1%><%-- All the variables will still be there, left over from whatever we just submitted --%> + <%else%> + <%set save_as = ""%> + <%set success_message = "Template saved successfully"%> + <%GT::Mail::Editor::tpl_load( + dir => $template_root, + template => $tpl_dir, + file => $template_file, + header => To, + header => Subject, + header => From + )%> + <%if error%> + <%set error_message = "Unable to load template: $error"%> + <%else%> + <%set displaying_template = 1%> + <%endif%> + <%endif%> +<%elsif load_template%> + <%if not tpl_file%> + <%set error_message = "Unable to load template: No template selected"%> + <%else%> + <%GT::Mail::Editor::tpl_load( + dir => $template_root, + template => $tpl_dir, + file => $tpl_file, + header => To, + header => From, + header => Subject + )%> + <%if error%> + <%set error_message = "Unable to load template: $error"%> + <%else%> + <%set displaying_template = 1%> + <%endif%> + <%endif%> +<%elsif restore_template%> + <%if not tpl_file%> + <%set error_message = "Unable to restore template: No template specified"%> + <%else%> + + <%GT::Mail::Editor::tpl_delete( + dir => $template_root, + template => $tpl_dir, + file => $tpl_file, + )%> + <%if error%> + <%set error_message = "Unable to restore template: $error"%> + <%set displaying_template = 1%> + <%else%> + <%set success_message = "Template restored successfully"%> + <%endif%> + + <%GT::Mail::Editor::tpl_load( + dir => $template_root, + template => $tpl_dir, + file => $tpl_file, + header => To, + header => Subject, + header => From + )%> + <%if error%> + <%set error_message = "Unable to load template: $error"%> + <%else%> + <%set displaying_template = 1%> + <%endif%> + <%endif%> +<%elsif delete_template%> + <%if not tpl_file%> + <%set error_message = "Unable to delete template: No template specified"%> + <%else%> + + <%GT::Mail::Editor::tpl_delete( + dir => $template_root, + template => $tpl_dir, + file => $tpl_file, + )%> + <%if error%> + <%set error_message = "Unable to delete template: $error"%> + <%set displaying_template = 1%> + <%else%> + <%set success_message = "Template deleted successfully"%> + <%endif%> + <%endif%> +<%elsif in.$setcookie%> + <%set displaying_template = 1%> +<%endif%> + + + + + + +
        + + + + + + + +
        + <%font_tag%>Email Templates +
        +

        <%font_tag%>Email Templates

        +

        <%font_tag%>From here you can quickly edit the e-mail templates for any e-mails sent. + <%if success_message%>

        <%font_tag%><%success_message%>

        <%endif%> + <%if error_message%>

        <%font_tag%><%error_message%>

        <%endif%> +
        +
        +
        +
        + + + + + + + +
        + + + + +
        +<%Links::Tools::tpl_dir_select($tpl_dir, 'browser')%> +<%Links::Tools::tpl_file_select($tpl_dir, '', '.*\.eml')%> +

        <%font_tag%>Currently working on template set:

        +

        <%font_tag%>Available templates:

        +

        <%font_tag%>* modified template
        + + non-default template

        + <%if tpl_local%>

        <%font_tag%>Template actions: <%if tpl_new_local%>diff or Restore<%else%>Delete<%endif%>

        <%endif%> + + + + + + + + + + + + + + + + +
        + <%font_tag%>To: + + +
        + <%font_tag%>From: + + +
        + <%font_tag%>Subject: + + +
        + <%font_tag%>Extra Headers:
        + +
        + <%font_tag%>Body:
        + +
        +

        <%font_tag%>Save template as:

        +

        <%font_tag%>Resize Textarea to: rows, columns

        +
        +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_global.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_global.html new file mode 100644 index 0000000..6e6ffef --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_global.html @@ -0,0 +1,57 @@ +<%Links::Tools::global_editor%> +<%Links::Tools::tpl_dir_select($tpl_dir, '(?:browser|admin)')%> + + + +Gossamer Links - Build - Globals + + + + + + +
        + + + + + + + +
        Edit + Globals
        +

        Edit + Globals

        +

        From here you can + quickly edit globals that can be used in any template. +<%if message%> +

        <%message%>

        +<%endif%> +
        +
        + +
        +
        + + + + +
        + + +
        + +

        Currently working on template set:

        + +

        <%global_table%>

        + +

        +
        +
        +
        + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_help.html new file mode 100644 index 0000000..600d210 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_help.html @@ -0,0 +1,33 @@ + + + +Gossamer Links - Build - Help + + + + + + + + + +
        + +

        Build

        + +
        +

        At its heart, Gossamer Links + generates HTML pages. It builds one or more separate HTML pages for each + category, plus other pages like a What's New listing, a What's Cool + listing, Top Rated pages and many more. From here, you can build the html + pages, and control how the pages will look.

        +

        Your template editor lets + you easily change any aspect of how your directory looks. Gossamer Links comes + with one template set, but please feel free to modify and create your own. + It's as easy as editing HTML pages. 

        +

         

        +

         

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_lang.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_lang.html new file mode 100644 index 0000000..f1e6954 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_lang.html @@ -0,0 +1,47 @@ +<%Links::Tools::language_editor%> +<%Links::Tools::tpl_dir_select($tpl_dir, '(?:browser|admin)')%> + + + +Gossamer Links - Build - Languages + + + + + +<%Links::header ('Edit Language','From here you can quickly edit the language settings of your templates.')%> + +
        +
        + + +<%if prefix%><%endif%> + + +
        + + +
        +

        Currently working on template set:

        + +<%if message%> +

        <%message%>

        +<%endif%> + +<%ifnot prefix%> +

        The languages have been broken up into categories, please pick the category you wish +to edit first. +<%endif%> + +

        <%prefix_list%>

        + +<%if prefix%> +

        <%language_table%>

        +<%endif%> +

        +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_nav.html new file mode 100644 index 0000000..156fcc5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_nav.html @@ -0,0 +1,51 @@ + + + + + Gossamer Links - Build - Nav + + <%include include_style.html%> + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_tpl.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_tpl.html new file mode 100644 index 0000000..5e8ebda --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/build_tpl.html @@ -0,0 +1,97 @@ +<%Links::Tools::template_editor%> +<%Links::Tools::tpl_dir_select($tpl_dir, '(?:browser|admin)')%> +<%Links::Tools::tpl_file_select($tpl_dir, '(?:\..*|.*\.eml|globals\.txt|language\.txt)')%> +<%set font_tag = ''%> + + + +Gossamer Links - Build - Templates + + + + + +
        + + + + + + + +
        Edit + Templates
        +

        Edit + Templates

        +

        <%font_tag%>From here you can quickly edit any of your user templates. Note: If you edit your + templates manually, be sure to read the template + help for where to save your templates! + <%if success_message%> +

        <%font_tag%><%success_message%>

        + <%endif%> + <%if error_message%> +

        <%font_tag%><%error_message%>

        + <%endif%> +
        +
        + +
        +
        + + + + +
        + + +
        + +

        <%font_tag%>Currently working on template set:

        + +

        <%font_tag%>Available templates:

        +

        <%font_tag%>* modified template
        + + non-default template

        + +<%if tpl_file%> +
        + + + + + + + + + + + + + + + + + + + +
        <%font_tag%>File information:
        <%font_tag%>Admin path:<%font_tag%><%file_path%>
        <%font_tag%>File size:<%font_tag%><%file_size%> bytes
        <%font_tag%>Status:<%font_tag%> +<%if file_local%> +<% if file_restore%>Modified from system default (diff) - Restore +<% else%>Custom template - Delete +<% endif%> +<%else%>Default system template +<%endif%> +
        <%font_tag%>Last modified:<%font_tag%><%file_mod_time%>
        +
        +<%endif%> + +

        +

        +

        <%font_tag%>Save template as: +

        +

        <%font_tag%>Resize Textarea to: rows, columns

        +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/copyright.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/copyright.html new file mode 100644 index 0000000..0f71b7b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/copyright.html @@ -0,0 +1,2 @@ +

        Copyright 2006 Gossamer +Threads Inc. 

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db.html new file mode 100644 index 0000000..a28b4b6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db.html @@ -0,0 +1,19 @@ + + + +Gossamer Links - Database + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_help.html new file mode 100644 index 0000000..f929c28 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_help.html @@ -0,0 +1,29 @@ + + + +Gossamer Links - Database - Help + + + + + + + + + +
        +

        Database

        +
        +

        All the information in + Gossamer Links is stored in an SQL database. The Database screen provides a + quick easy way to access the three main tables in Gossamer Links: Links, + Categories and Users. From there you can quickly search for an individual + link, or add new records quickly.

        +

        You'll also find a number + of tools to help keep your database in check. From our popular MySQLMan + tool, to a sophisticated Link checker.

        +

         

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_nav.html new file mode 100644 index 0000000..3eee11e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/db_nav.html @@ -0,0 +1,122 @@ +<%Links::SQL::load%> + + + +Gossamer Links - Database - Nav + + + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + +
         Editor

        +  
        +  
        +     + +
         Tools
        +   Validate Links
        +   Validate Changes
        +   Validate Reviews
        +   View Search Logs
        +   Verify Links
        +   Link Status
        +   Check Duplicates
        +   Purge Expired Links
        +   Import/Export
        +<%if driver eq 'mysql'%> +   MySQLMan
        +<%endif%> +   SQL Monitor
        +  
          + Repair
        +   Rebuild Cat. tree
        +   Repair Tables
        +   Rebuild Search
        +  
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_cancel_mailing.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_cancel_mailing.html new file mode 100644 index 0000000..375bdf6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_cancel_mailing.html @@ -0,0 +1,34 @@ + + +Gossamer Links Email: Confirm Cancel Mailing + + + +

        Confirm Mailing <%Verbtion%>

        +You must confirm before the following email is <%verbed%>
        +
        + + + + +
        +
        + + +
        +

        +

        Mailing details

        +
        +Mailing ID: <%id%>
        +<%if finished%>Mailing Completed: <%finished%>
        +<%endif%>
        +To: <%count%> recipients
        +From: "<%name%>" <<%mailfrom%>>
        +Subject: <%subject%>
        +Message (format: <%messageformat%>):
        +
        +<%message%> +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_all_mailings.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_all_mailings.html new file mode 100644 index 0000000..b547319 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_all_mailings.html @@ -0,0 +1,19 @@ + + +Gossamer Links Email: Confirm Delete All Mailings + + + +

        Confirm Delete All Mailings

        +You must confirm before all <%count%> mailings are cancelled deleted.
        +
        + + +
        +
        + + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_finished_mailings.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_finished_mailings.html new file mode 100644 index 0000000..268b7b4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_confirm_delete_finished_mailings.html @@ -0,0 +1,20 @@ + + +Gossamer Links Email: Confirm Delete All Finished Mailings + + + +

        Confirm Delete All Finished Mailings

        +You must confirm before the <%count%> finished mailings will be deleted. +Currently pending mailings will not be affected.
        +
        + + +
        +
        + + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_contents.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_contents.html new file mode 100644 index 0000000..7e08615 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_contents.html @@ -0,0 +1,48 @@ + + +Gossamer Links + + + + + + + + + + + + + + + + + + + + + + + + +
         Mass Mail +
        +   All Users
        +   All Links
        +   Selected Users
        +   Selected Links
        +   Newsletter
        +   +
         Custom + Lists +
        +   List
        +   Add
        +   Modify
        +   Delete
        +   Mail
        +  
         Current + Mailings
          View
        +
         
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_default.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_default.html new file mode 100644 index 0000000..e94abcb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_default.html @@ -0,0 +1,25 @@ + + +Gossamer Links <%version%> + + + + + + +
        +

        Email

        +
        +

        Included in Gossamer Links + is everything you need to keep in touch with your users. You are able + to send out newsletters to users that have subscribed letting them + know what's new with your site. You can send out custom emails, + letting each link owner know the current status of their link. You can + send targeted message to individual users, and much more.

        +

        Also, is a powerful + list management tool that lets you maintain separate mailing lists + that you can send messages to.

        +

         

        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_error.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_error.html new file mode 100644 index 0000000..265db15 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_error.html @@ -0,0 +1,12 @@ + + +Gossamer Links + + + +An error has occurred:

        +
        +<%error%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_everyone.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_everyone.html new file mode 100644 index 0000000..67cd0ad --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_everyone.html @@ -0,0 +1,126 @@ + + + +Gossamer Links Email: All Users + + + + +
        + + +
        + + + + + + + +
        Email: + All Users
        +

        All Users

        + +

        Send an e-mail to all users who are flagged to receive e-mail.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + +
        +This email will go out to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + +
        + + + + +
        From (name):
        From (email):
        Subject:
        Message format:
        Message:
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_frames.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_frames.html new file mode 100644 index 0000000..a6067cc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_frames.html @@ -0,0 +1,21 @@ + + + +Gossamer Links: Email + + + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_link_owners.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_link_owners.html new file mode 100644 index 0000000..aaed3fa --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_link_owners.html @@ -0,0 +1,125 @@ + + + +Gossamer Links Email: All Link Owners + + + + +
        + + +
        + + + + + + + +
        Email: + All Link Owners
        +

        All Link Owners

        +

        Send an e-mail to all link owners who have selected to receive e-mail.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + + +
        +This email will go out to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + +
        + + + + +
        From (name):
        From (email):
        Subject:
        Message format:
        Message:
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list.html new file mode 100644 index 0000000..8794b96 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list.html @@ -0,0 +1,15 @@ + + + +Gossamer Links Email: Address list + + + + + +<%addresses%> + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_add.html new file mode 100644 index 0000000..6ac7783 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_add.html @@ -0,0 +1,88 @@ + + + +Gossamer Links Email: Add Mailing List + + + + +
        + + +
        + + + + + + + +
        Email: + Add Mailing List
        +

        Add Mailing List

        + +

        Add a list of e-mail addresses to the list of mailing lists.
        +  

        +
        +
        + +
        + +<%if message%> + + + + +
        + + + + +
        + <%message%> +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + +List name:


        +Enter addresses, separated by spaces or new lines:
        +
        +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_added.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_added.html new file mode 100644 index 0000000..e207e50 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_added.html @@ -0,0 +1,29 @@ + + + +Gossamer Links Email: Added Mailing List + + + + + +
        + + + + + + + +
        Email: + Added Mailing List
        +

        Added Mailing List

        + +

        <%status%>
        +  

        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete.html new file mode 100644 index 0000000..6f86e44 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete.html @@ -0,0 +1,71 @@ + + + +Gossamer Links Email: Delete Mailing List + + + + + + + +
        + + + + + + + +
        Email: + Delete Mailing List
        +

        Delete Mailing List

        + +

        Completely delete a custom mailing list.
        +  

        +
        +
        + +
        + + + + + +
        + + + + +
        + +Select a list to delete

        +<%list%> +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete_list.html new file mode 100644 index 0000000..7ecea6b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_delete_list.html @@ -0,0 +1,29 @@ + + + +Gossamer Links Email: List deleted + + + + + +
        + + + + + + + +
        Email: + List deleted
        +

        List deleted

        + +

        Table <%Name%> has been deleted.
        +  

        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_list.html new file mode 100644 index 0000000..1939c52 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_list.html @@ -0,0 +1,15 @@ + + +Gossamer Links + + + +<%Name%>
        +
        +Created: <%DateCreated%>
        +Last modified: <%DateModified%>
        +
        +<%addresses%> +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail.html new file mode 100644 index 0000000..43e5ef1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail.html @@ -0,0 +1,71 @@ + + + +Gossamer Links Email: Mail to Mailing List + + + + +
        + + +
        + + + + + + + +
        Email: + Mail to Mailing List
        +

        Mail to Mailing List

        + +

        Send an email message to all members of a custom mailing list.
        +  

        +
        +
        + +
        + + + + + +
        + + + + +
        + +Select the mailing list to which the E-mail should be sent

        +<%list%> +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail_list.html new file mode 100644 index 0000000..0912993 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_mail_list.html @@ -0,0 +1,125 @@ + + + +Gossamer Links Email: Mail Mailing List + + + + +
        + + + +
        + + + + + + + +
        Email: + Mail Mailing List
        +

        Mail Mailing List

        +

        Send an email message to all members of a custom mailing list.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        +
        +This email will go out to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + +
        + + + + + + +
        From (name):
        From (email):
        Subject:
        Message:
        Message:
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_moded.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_moded.html new file mode 100644 index 0000000..d4bf04f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_moded.html @@ -0,0 +1,29 @@ + + + +Gossamer Links Email: Modified Mailing List + + + + + +
        + + + + + + + +
        Email: + Modified Mailing List
        +

        Modified Mailing List

        + +

        <%status%>
        +  

        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify.html new file mode 100644 index 0000000..ae51727 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify.html @@ -0,0 +1,70 @@ + + + +Gossamer Links Email: Modify Mailing List + + + + + + + +
        + + + + + + + +
        Email: + Modify Mailing List
        +

        Modify Mailing List

        +

        Make changes to an existing mailing list
        +  

        +
        +
        + +
        + + + + + +
        + + + + +
        + +Select a list to modify

        +<%list%> +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify_list.html new file mode 100644 index 0000000..f087fda --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_modify_list.html @@ -0,0 +1,73 @@ + + + +Gossamer Links Email: Modify Mailing List + + + + +
        + + +
        + + + + + + + +
        Email: + Modify Mailing List
        +

        Modify Mailing List

        +

        Make changes to an existing mailing list
        +  

        +
        +
        + +
        + + + + + +
        + + + + +
        + +List name:
        <%Name%>

        +Enter addresses, separated by spaces or new lines:
        +
        + +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_of_lists.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_of_lists.html new file mode 100644 index 0000000..393174b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_list_of_lists.html @@ -0,0 +1,45 @@ + + +Gossamer Links Email: List of Mailing Lists + + + + +
        + + + + + + + +
        Email: + List of Mailing Lists
        +

        List of Mailing Lists

        + +

        View existing mailing lists and the date created/last modified of the lists.
        +  

        +
        +
        + +
        + + + + + +
        + + + + +
        + + <%lists%> + +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailing_detail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailing_detail.html new file mode 100644 index 0000000..60f1a89 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailing_detail.html @@ -0,0 +1,21 @@ + + +Gossamer Links + + + +

        Mailing details

        +
        +Mailing ID: <%id%>
        +<%if finished%>Mailing Completed: <%finished%>
        +<%endif%>
        +To: <%count%> recipients
        +From: "<%name%>" <<%mailfrom%>>
        +Subject: <%subject%>
        +Message (Message format: <%messageformat%>):
        +
        +<%message%> +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailings.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailings.html new file mode 100644 index 0000000..bab2c7f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_mailings.html @@ -0,0 +1,77 @@ + + + +Gossamer Links Email: View Mailings + + + + + +
        + + + + + + + +
        Email: + View Mailings
        +

        View Mailings

        + +

        View/send/delete currently queued mailings and completed mailings.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + + +
        +
        +
          +<%mailings%> +
        +

        +Delete all completed mailings +| +Cancel/Delete all mailings +
        + +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter.html new file mode 100644 index 0000000..acf3cdc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter.html @@ -0,0 +1,122 @@ + + + +Gossamer Links Email: Newsletter + + + + +
        + + +
        + + + + + + + +
        Email: + Newsletter
        +

        Newsletter

        + +

        Send an e-mail consisting of all New links to all users who are configured to receive the newsletter.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + +<%if ID%>><%endif%> + + +
        +This email will go out to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + + Edit newsletter template + +
        From (name):
        From (email):
        Subject:
        Message:
        Message:
        + +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_browse.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_browse.html new file mode 100644 index 0000000..98688ce --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_browse.html @@ -0,0 +1,94 @@ + +<%Links::Newsletter::admin_browse%> + + + Newsletter + +<%include include_style.html%> + + + + +<%set header_title = 'Newsletter'%> +<%set header_details = "Click the [+] beside a desired category to see information on that category's subscribers. You will have the option of sending a newsletter to that category's subscribers. Direct subscribers are those who have signed up specifically for that category's newsletter. The number of total subscribers represents all direct subscribers as well as those who have signed up for the parent category\'s newsletter. Click on the number of either total or direct subscribers to see a list of those e-mail addresses. Categories that match the maximum depth setting in the User Options Setup menu will be linked to lists of further sub-categories."%> +<%include include_header.html%> + + + + +
        + <%if PPID ne ''%>Back to <%PPName%>
        <%endif%> +<%loop category%> +
        + <%if HasMoreChildren%><%endif%><%Name%><%if HasMoreChildren%><%endif%> [+]
        +
        + Subscribers: <%if Subscribers%><%endif%><%Subscribers%><%if Subscribers%><%endif%> / <%if DirectSubscribers%><%endif%><%DirectSubscribers%><%if DirectSubscribers%><%endif%> (Total/Direct)
        + <%if Subscribers%>Send newsletter to this category
        <%endif%> +
        +
        +<%endloop%> +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_edit_template.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_edit_template.html new file mode 100644 index 0000000..955a750 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_edit_template.html @@ -0,0 +1,139 @@ + + + +Gossamer Links Email: Edit Newsletter Template + + + + + + + +
        + + + + + + + +
        Email: + Edit Newsletter Template
        +

        Edit Newsletter Template

        +

        Change the template for the newsletter
        +  

        +
        +
        + +
        +<%if bad_email%> + + + + + +
        + + + + +
        + + All fields must be entered as well as have a valid e-mail address entered. Correct it before saving the template. + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + +
        + From (name): + + +
        + From (email): + + +
        + Subject: + + +
        + Message format: + +
        + Message: + + +
        + Newsitem Template: + + +
        + +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + + +
        +
        +
        + + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_subscribers.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_subscribers.html new file mode 100644 index 0000000..6488d23 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newsletter_subscribers.html @@ -0,0 +1,23 @@ + +<%Links::Newsletter::subscriber_info%> + + + Newsletter Subscribers + + + + +

        + <%loop subscribers%> + <%Email%>
        + <%endloop%> +

        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newtemp_save_as.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newtemp_save_as.html new file mode 100644 index 0000000..af54977 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_newtemp_save_as.html @@ -0,0 +1,97 @@ + + + +Gossamer Links Email: New Template Save As... + + + + +
        + + +
        + + + + + + + +
        Email: + New Template Save As...
        +

        New Template Save As...

        + +

        Enter a name for the new template
        +  

        +
        +
        + +
        + +<%if notes%> + + + + +
        + + + + +
        + +

        Error:

        +<%notes%> +
        +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        + +Enter template name:
        + + + + + + +<%hidden_fields%> +<%if extra%> +<%endif%> +
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + + +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links.html new file mode 100644 index 0000000..8711604 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links.html @@ -0,0 +1,74 @@ + + +Gossamer Links Email: Selected Link Owners + + + + + + +
        + + + + + + + +
        Email: + Selected Link Owners
        +

        Selected Link Owners

        + +

        Send an e-mail to the owners of the results of a link search. Links whose owners are set to not receive mail will not be included in the results of the search.
        +  

        +
        +
        + +
        + +<%if message%> + + + + +
        + + + + +
        + + <%message%> + +
        +
        + +
        + +<%endif%> + +<%form%> + +
        + + + + + +
        + + + + +
        +
        + + + +
        +
        +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links_mail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links_mail.html new file mode 100644 index 0000000..d86c88c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_links_mail.html @@ -0,0 +1,124 @@ + + + +Gossamer Links Email: Selected Link Owners + + + + +
        + + + +
        + + + + + + + +
        Email: + Selected Link Owners
        +

        Selected Link Owners

        + +

        Send an e-mail to the owners of the results of a link search. Links whose owners are set to not receive mail will not be included in the results of the search.
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        +
        +This email has been selected to go to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        +<%hidden_fields%> + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + +
        + + + + +
        From (name):
        From (email):
        Subject:
        Message:
        Message:
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users.html new file mode 100644 index 0000000..a3b37d3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users.html @@ -0,0 +1,79 @@ + + + +Gossamer Links Email: Selected Users + + + + + + + +
        + + + + + + + +
        Email: + Selected Users
        +

        Selected Users

        + +

        Send an e-mail to the results of a user search
        +  

        +
        +
        + +
        + +<%if message%> + + + + +
        + + + + +
        + + <%message%> + +
        +
        + +
        + +<%endif%> + +<%form%> + + +
        + + + + + +
        + + + + +
        +
        + + + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users_mail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users_mail.html new file mode 100644 index 0000000..b16f394 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/email_selected_users_mail.html @@ -0,0 +1,127 @@ + + + +Gossamer Links Email: Selected Users + + + + +
        + + + +
        + + + + + + + +
        Email: + Selected Users
        +

        Selected Users

        + +

        Send an e-mail to the results of a user search
        +  

        +
        +
        + +
        +<%if error%> + + + + + +
        + + + + +
        + + <%error%> + +
        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        +
        +This email has been selected to go to <%number%> address<%ifnot number == 1%>es<%endif%>.
        +
        +<%hidden_fields%> + + + + + + + + + + + + + + + + + + + + + + + + + +
        + Template: + +
        + + + + +
        From (name):
        From (email):
        Subject:
        Message format:
        Message:
        +
        +
        + +
        + + + + + +
        + + + + +
        +
        + +
        +
        +
        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/error.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/error.html new file mode 100644 index 0000000..a2103b6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/error.html @@ -0,0 +1,18 @@ + + + +Gossamer Links <%cfg_version%>: Error + + + +Gossamer Links Error: +

        The following error occurred:

        +
        <%error%>
        +

        The following is some debugging +information that may help:

        +
        <%Links::environment%>
        +

        For support, please visit: +http://gossamer-threads.com/scripts/support/.

        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/blank.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/blank.html new file mode 100644 index 0000000..dfc89af --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/blank.html @@ -0,0 +1,5 @@ + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom.html new file mode 100644 index 0000000..7ceb429 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom.html @@ -0,0 +1,8 @@ + +
        +
        + +
        <%font%>Status:Please enter the command you wish to execute
        <%font%>Command: +
        + +
        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom_frame.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom_frame.html new file mode 100644 index 0000000..7da902e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/bottom_frame.html @@ -0,0 +1,7 @@ + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor.js b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor.js new file mode 100644 index 0000000..4cd11f8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor.js @@ -0,0 +1,1201 @@ +/* + * ================================================================= + * HTML Editor - A wysiwyg web based editor for Mozilla V1.4+ + * Website : http://gossamer-threads.com/ + * Revision : $Id: editor.js,v 1.20 2004/04/08 17:40:46 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. + * ================================================================= + * + * Description: Common functions needed to display the toolbar for an + * HTML-editing iframe, as used in Gossamer Forum. + */ + +/* -- Javascript needed to write a post -- */ +var iframe, editor, inner_content, outerdoc, main_form; +var pressedInterval, initializing, initialized, editorWidth, windowResized; + +var inner_content_loaded = false; + +var controlRange; // selection is a ControlRange collection + +window.onresize = window_resize; + +var unStack = new Array(); +var reStack = new Array(); +var unPress = false; + +var input = parent.load_param(); +var baseURL = input[0]; +var extraURL = input[1]; +var imageURL = input[2]; +var mainForm = input[3]; +var contentObj = input[4]; +var formTools = input[5]; +var temp_id = input[6]; +var attachments = input[7]; + +var dialogWindow = new Object(); + +var is_ie = <%if is_ie%>true<%else%>false<%endif%>; +var doc_attr = is_ie ? 'document' : 'contentDocument'; + +function window_resize () { + windowResized = true; +} + +var initOuterIFrameCalled = false; + +function initOuterIFrame () { + if (initOuterIFrameCalled) return; + else initOuterIFrameCalled = true; + + if (is_ie) + outerdoc = parent.document.frames.editor_iframe.document; + else + outerdoc = parent.document.getElementById('editor_iframe').contentDocument; + + setTimeout("initInnerIFrame()", 100); +} + +// Somehow, initInnerIFrame is sometimes called simultaneously; this lock +// variable locks out any subsequent calls +var initInnerIFrameLocked = false; + +function initInnerIFrame () { + if (initInnerIFrameLocked) return; + initInnerIFrameLocked = true; + + var varsOkay = false; + + if (is_ie) iframe = outerdoc.frames.editor_iframe; + else iframe = outerdoc.getElementById('editor_iframe'); + if ((is_ie || inner_content_loaded) && iframe) { + main_form = parent.document[mainForm]; + if (main_form) { + editor = iframe[doc_attr]; + if (editor) { + inner_content = editor.getElementById('inner_content'); + if (inner_content) { + if (is_ie) inner_content.contentEditable = true; + else editor.designMode = "on"; + varsOkay = true; + } + } + } + } + + if (!varsOkay) { + setTimeout("initInnerIFrame()", 100); + initInnerIFrameLocked = false; + return; + } + + try { + editor.execCommand("Undo", false, null); + } catch (e) { + alert("The HTML editor does not appear to be supported by your browser: " + e); + } + + //if (!is_ie) editor.execCommand("useCSS", false, null); + + initHTML(); + + setTimeout("toolbarInit()", 100); + main_form.onsubmit = retrieveHTML; + + if (!pressedInterval) pressedInterval = setInterval("calcPressed()", 150); +} + +var pressLoopInit = false; +var pressButtons = {}; +var pressLoop = []; + +function calcPressed () { + if (windowResized) { + tb_layout(); + windowResized = false; + } + + if (is_ie) controlRange = (editor.selection.type == "Control") ? true : false; + + if (!pressLoopInit) { + pressLoop[pressLoop.length] = 'Bold'; + pressButtons['Bold'] = [outerdoc.getElementById('bold'), outerdoc.getElementById('boldImage')]; + + pressLoop[pressLoop.length] = 'Italic'; + pressButtons['Italic'] = [outerdoc.getElementById('italic'), outerdoc.getElementById('italicImage')]; + + pressLoop[pressLoop.length] = 'Underline'; + pressButtons['Underline'] = [outerdoc.getElementById('underline'), outerdoc.getElementById('underlineImage')]; + + pressLoop[pressLoop.length] = 'JustifyLeft'; + pressButtons['JustifyLeft'] = [outerdoc.getElementById('jleft'), outerdoc.getElementById('jleftImage')]; + + pressLoop[pressLoop.length] = 'JustifyCenter'; + pressButtons['JustifyCenter'] = [outerdoc.getElementById('jcenter'), outerdoc.getElementById('jcenterImage')]; + + pressLoop[pressLoop.length] = 'JustifyRight'; + pressButtons['JustifyRight'] = [outerdoc.getElementById('jright'), outerdoc.getElementById('jrightImage')]; + + pressLoop[pressLoop.length] = 'InsertOrderedList'; + pressButtons['InsertOrderedList'] = [outerdoc.getElementById('ol'), outerdoc.getElementById('olImage')]; + + pressLoop[pressLoop.length] = 'InsertUnorderedList'; + pressButtons['InsertUnorderedList'] = [outerdoc.getElementById('ul'), outerdoc.getElementById('ulImage')]; + + pressLoopInit = true; + } + + for (var i = 0; i < pressLoop.length; i++) { + var pressed = editor.queryCommandState(pressLoop[i]); + var span = pressButtons[pressLoop[i]][0]; + var image = pressButtons[pressLoop[i]][1]; + + if (pressed && !span.isPressed) press(span, image); + else if (!pressed && span.isPressed) unpress(span, image); + else if (span.isPressed == null) span.isPressed = false; + } + + var buttons = { + 'link' : 'CreateLink', + 'bold' : 'Bold', + 'italic' : 'Italic', + 'underline' : 'Underline', + 'ol' : 'InsertOrderedList', + 'ul' : 'InsertUnorderedList', + 'od' : 'Outdent', + 'id' : 'Indent', + 'font' : 'FontName', + 'fcolor' : 'ForeColor', + 'horRule' : 'InsertHorizontalRule', + 'insImage' : 'InsertImage' + }; + if (is_ie) { + buttons['cut'] = 'Cut'; + buttons['copy'] = 'Copy'; + buttons['paste'] = 'Paste'; + } + if (formTools) { + buttons['form'] = 'Bold'; + buttons['text'] = 'Bold'; + buttons['textarea'] = 'Bold'; + buttons['checkbox'] = 'Bold'; + buttons['radio'] = 'Bold'; + buttons['select'] = 'Bold'; + buttons['button'] = 'Bold'; + } + + for (var i in buttons) { + var querycommand = buttons[i]; + var button = outerdoc.getElementById(i); + var possible = false; + try { + possible = editor.queryCommandEnabled(querycommand); + } catch (e) { } + + if ( possible && button.disabled) + enable(button); + else if (!possible && !button.disabled) + disable(button); + } + + if (!is_ie) return; + + var bool_table = check_env(); + + if ( bool_table ) { + if (outerdoc.all.insCell.disabled) enable (outerdoc.all.insCell); + if (outerdoc.all.insRow.disabled) enable (outerdoc.all.insRow); + if (outerdoc.all.insCol.disabled) enable (outerdoc.all.insCol); + if (outerdoc.all.delCell.disabled) enable (outerdoc.all.delCell); + if (outerdoc.all.delRow.disabled) enable (outerdoc.all.delRow); + if (outerdoc.all.delCol.disabled) enable (outerdoc.all.delCol); + if (outerdoc.all.split.disabled) enable (outerdoc.all.split); + } + else { + if (!outerdoc.all.insCell.disabled) disable (outerdoc.all.insCell); + if (!outerdoc.all.insRow.disabled) disable (outerdoc.all.insRow); + if (!outerdoc.all.insCol.disabled) disable (outerdoc.all.insCol); + if (!outerdoc.all.delCell.disabled) disable (outerdoc.all.delCell); + if (!outerdoc.all.delRow.disabled) disable (outerdoc.all.delRow); + if (!outerdoc.all.delCol.disabled) disable (outerdoc.all.delCol); + if (!outerdoc.all.split.disabled) disable (outerdoc.all.split); + } + if (check_merge()) { + if (outerdoc.all.merge.disabled) enable(outerdoc.all.merge); + } + else { + disable(outerdoc.all.merge); + } +} + +function initHTML(type) { + var initValue = main_form.pre_content.value; + var epos = initValue.search('',''); + parent.document[mainForm].header.value = head; + + initValue = initValue.replace(head,''); + initValue = initValue.replace('',''); + if (type) { + inner_content.innerHTML = ''; + iframe.focus(); + var selection = editor.selection.createRange(); + var html = htmlUNESCAPE(initValue); + selection.pasteHTML(html); + iframe.focus(); + } + else { + inner_content.innerHTML = initValue; + } +} + +function htmlESCAPE(content) { + content = content.replace(/\&/gi,'&'); + content = content.replace(/\/gi,'>'); + content = content.replace(/\"/gi,'"'); + return content; +} + +function htmlUNESCAPE(content) { + content = content.replace(/(\<\;)/gi,'<'); + content = content.replace(/(\>\;)/gi,'>'); + content = content.replace(/(\"\;)/gi,'"'); + content = content.replace(/(\&\;)/gi,'&'); + return content; +} + +function press (button, image) { // Takes a span from the outer iframe and "presses" it. + button.isPressed = true; + button.className = "menu_item_mouseoverdown"; + image.className = "icon_down"; +} + +function unpress (button, image) { // Takes one of the spans from the editor_iframe page and unpresses the button + button.isPressed = false; + button.className = "tb_menu_item"; + image.className = "tb_icon"; +} + +function disable (button) { // Disables a span + button.className = "tb_menu_item"; + button.disabled = true; + if (is_ie) + button.style.filter = "progid:DXImageTransform.Microsoft.Alpha(style=0, opacity=25)"; + else { + var agent = navigator.userAgent; + var ver = /Mozilla\/5\.0\s*\(X11; [^)]*; rv:(\d\.\d+)([ab]?)\)/.exec(agent); + // GTK2 Mozilla/Firebird/etc. builds do not properly support the -moz-opacity style. This + // is mozilla bug 201209, which was fixed in the 1.6 trunk on 2003-11-01. Therefore, if + // on X11, we require >= 1.6b in order to enable the mozopacity style. + if (!ver || (ver.index >= 0 && (ver[1] > 1.6 || (ver[1] == 1.6 && (!ver[2] || ver[2] >= 'b'))))) + button.style.MozOpacity = 0.25; + } +} + +function enable (button) { // Enables a span + button.disabled = false; + if (is_ie) + button.style.filter = null; + else + button.style.MozOpacity = 1; +} + +var pressLoopInit = false; +var pressButtons = {}; +var pressLoop = []; + +function retrieveHTML () { + var body = inner_content.innerHTML; + var head = main_form.header.value + if (body){ + var style = /style="BORDER-RIGHT: red 1px dotted; PADDING-RIGHT: 2px; BORDER-TOP: red 1px dotted; PADDING-LEFT: 2px; PADDING-BOTTOM: 2px; BORDER-LEFT: red 1px dotted; PADDING-TOP: 2px; BORDER-BOTTOM: red 1px dotted"/gi; + body = body.replace(style,''); + body = body.replace('id=inner_content contentEditable=true',''); + + var html = '' + head + body + '\n'; + html = html.replace(/\n\s/gi,''); + main_form.content.value = html; + } +} + + +function command (cmd) { + setFocus(); + editor.execCommand(cmd, false, null); +} + +var colorCmd = 'ForeColor'; +function colorDialog (id, cmd) { + setFocus(); + if (cmd != 'ForeColor' && is_ie ) { + colorCmd = 'BackColor'; + } + else { + colorCmd = cmd; + } + + if (!is_ie) dialogWindow.currentColor = editor.queryCommandValue(cmd); + showDialog('editor_color', 345, 193, returnColor); +} + +function fontLoad(fontSelect, styleSelect, sizeSelect, underlineCheckbox) { + if (typeof(editor) == 'undefined') return; + + var name = editor.queryCommandValue('FontName').toLowerCase(); + var size = editor.queryCommandValue('FontSize'); + var bold = editor.queryCommandState('Bold'); + var italic = editor.queryCommandState('Italic'); + var underline = editor.queryCommandState('Underline'); + + if (name != '') { + for (i=0; i < fontSelect.length; i++) { + if (fontSelect.options[i].text.toLowerCase() == name) { + fontSelect.selectedIndex = i; + break; + } + } + } + if (size) { + for (i=0; i < sizeSelect.length; i++) { + if (sizeSelect.options[i].value == size) { + sizeSelect.selectedIndex = i; + break; + } + } + } + styleSelect.value = bold && italic ? 'bi' : bold ? 'b' : italic ? 'i' : 'r'; + underlineCheckbox.checked = underline; +} + +function returnFont (font, size, color, bold, italic, underline) { + var nowB = editor.queryCommandState('Bold'); + var nowI = editor.queryCommandState('Italic'); + var nowU = editor.queryCommandState('Underline'); + + setFocus(); + if (font) editor.execCommand('FontName', false, font); + if (size) editor.execCommand('FontSize', false, size); + if (color) editor.execCommand('ForeColor', false, color); + if (bold && !nowB || !bold && nowB) editor.execCommand('Bold', false, null); + if (italic && !nowI || !italic && nowI) editor.execCommand('Italic', false, null); + if (underline && !nowU || !underline && nowU) editor.execCommand('Underline', false, null); +} + +function returnColor (color) { + setFocus(); + if (!color) return; + if ( colorCmd == 'ForeColor' ) { + editor.execCommand(colorCmd, false, color); + return; + } + + if (is_ie) { + if (controlRange) { + var oControlRange = editor.selection.createRange(); + for (i = 0; i < oControlRange.length; i++) { + if (oControlRange(i).tagName.toUpperCase() == "TABLE") + oControlRange(i).bgColor = color; + } + } + else { + if (getSelection()) { + editor.execCommand(colorCmd, false, color); + } + else inner_content.bgColor = color; + } + } + else if ( getSelection() ) { + editor.execCommand(colorCmd, false, color); + } + else inner_content.bgColor = color; +} + +function returnLink (url) { + if (url == '' || url == 'http://') + return; + + setFocus(); + editor.execCommand('CreateLink', false, url); +} + +function returnImage (object) { + if (typeof(object) == 'undefined') + return; + + setFocus(); + insertNodeAtSelection(object); +} + +function setFocus () { + var obj; + if (is_ie) + obj = inner_content; + else + obj = document.getElementById("editor_iframe").contentWindow; + obj.focus(); +} + +function showDialog (do_equals, width, height, dialogReturn) { +/*------------------------------------------------------------ + * show dialog window + */ + var url = baseURL + ';page=' + do_equals + '.html;' + extraURL; + + if (dialogWindow.win && !dialogWindow.win.closed && dialogWindow.url == url) { + dialogWindow.win.focus(); + } + else { + if (dialogWindow.win && !dialogWindow.win.closed) dialogWindow.win.close(); + dialogWindow.returnFunc = dialogReturn; + dialogWindow.url = url; + dialogWindow.width = width; + dialogWindow.height = height; + dialogWindow.name = Math.random().toString().replace(/\./, ""); + + dialogWindow.left = (screen.width - width) / 2; + dialogWindow.top = (screen.height - height) / 2; + dialogWindow.attribs = 'left=' + dialogWindow.left + ',' + + 'top=' + dialogWindow.top + ',' + + 'resizable=no,statusbar=no,' + + 'width=' + dialogWindow.width + ',' + + 'height=' + dialogWindow.height; + + dialogWindow.win = window.open(dialogWindow.url, dialogWindow.name, dialogWindow.attribs); + dialogWindow.win.focus(); + } +} + +function getSelection () { + var ret; + if (is_ie) { + ret = editor.selection.createRange().htmlText; + } + else { + var span = document.createElement("span"); + + var sel = document.getElementById('editor_iframe').contentWindow.getSelection(); + span.appendChild(sel.getRangeAt(sel.rangeCount-1).cloneContents()); + ret = span.innerHTML; + } + return ret; +} + +/* Table's feature: insert table, insert/delete/merge cell, insert row/col */ + +function returnTable(rows, cols, width, padding, spacing, border) { + var table = editor.createElement("TABLE"); + var tbody = editor.createElement("tbody"); + var cols = cols || 3; + var rows = rows || 3; + table.width = width || '100%'; + table.border = border || 1; + table.cellPadding = padding || 1; + table.cellspacing = spacing || 1; + + //create rows and cells + if (cols > 0 && rows >0) { + for (var i=0; i < rows; i++) { + var tr = editor.createElement("tr"); + for (var j=0; j < cols; j++) { + var td = editor.createElement("td"); + td.innerHTML = ' '; + tr.appendChild(td); + } + tbody.appendChild(tr); + } + table.appendChild(tbody); + } + setFocus(); + insertNodeAtSelection(table); +} + +function insert_row() { +/* ------------------------------------------------------------ + * Insert new row + */ + var mytable = selected_table(); + if (mytable) { + var currentRow = selected_tr(mytable); + var cols = mytable.rows[currentRow].cells.length; + var oRow = mytable.insertRow(currentRow); + for (var i=0; i=0) ? nrow : selected_tr(mytable); + var currentCol = (ncol >=0) ? ncol : selected_td(mytable,currentRow); + mytable.rows[currentRow].insertCell(currentCol); + } +} + +function delete_row() { +/* ------------------------------------------------------------ + * Delete a row + */ + var mytable = selected_table(); + if (mytable) mytable.deleteRow(selected_tr(mytable)); +} + +function delete_col() { +/* ------------------------------------------------------------ + * Delete a column + */ + var mytable = selected_table(); + if (mytable) { + var currentRow = selected_tr(mytable); + var currentCol = selected_td(mytable,currentRow); + var rows = mytable.rows.length; + for (var i=0; i=0)? nrow : selected_tr(mytable); + var currentCol = (ncol >=0)? ncol : selected_td(mytable,currentRow); + if (currentCol < mytable.rows[currentRow].cells.length) mytable.rows[currentRow].deleteCell(currentCol); + if (mytable.rows[currentRow].cells.length == 0) mytable.deleteRow(currentRow); + } +} + +function split_cell() { +/* ------------------------------------------------------------ + * Split a cell + */ + var mytable = selected_table(); + if (!mytable) return + var currentRow = selected_tr(mytable); + var currentCol = selected_td(mytable,currentRow); + var rows = mytable.rows.length; + var cols = mytable.rows[currentRow].cells.length; + var span = mytable.rows[currentRow].cells[currentCol].colSpan; + for (var i=0; i 1) mytable.rows[i].cells[currentCol].colSpan--; + insert_cell(currentRow,currentCol); + } + else { + var ncol; + var nlen = mytable.rows[i].cells.length; + if ( span == 1) { + var jspan = 0; + for (var j=0; j= currentCol) { ncol = j; break; } + } + mytable.rows[i].cells[ncol].colSpan++; + } + else { + if (currentCol > 0 ) { + var jmax = 0; + var jcol = (currentCol >= nlen - 1) ? nlen - 1 : currentCol-1; + + for (var j=0; j= mlen-1) ? mlen - 1 : currentCol-1; + if (mytable.rows[j].cells[mcol].colSpan > jmax) jmax = mytable.rows[j].cells[mcol].colSpan; + } + if (mytable.rows[i].cells[jcol].colSpan == jmax) { ncol = currentCol; } + else { + var jspan = 0; + for (var j=0; j= 0) { + var data = ''; + var html = ''; + var count = 0; + var nspan = 0; + for (var i=begCol; i<=endCol; i++) { + if (mytable.rows[currentRow].cells[i].hasChildNodes()) { + if (mytable.rows[currentRow].cells[i].innerHTML) html += mytable.rows[currentRow].cells[i].innerHTML; + data += mytable.rows[currentRow].cells[i].childNodes.item(0).data + ' '; + } + nspan += mytable.rows[currentRow].cells[i].colSpan; + count++; + } + for (var i=begCol; i"); + var currentRow,begCol,endCol; + for (i=0; i"); + pos2 = items[i].indexOf("ch="); + tmp = items[i].substr(pos2+3,pos1-pos2-3) + + elem = tmp.split('-'); + if (i==0) { + currentRow = elem[0]; + begCol = elem[1]; + } + endCol = elem[1]; + } + } + return [currentRow,begCol,endCol]; +} + +function selected_table () { +/* ------------------------------------------------------------ + * Return a current table object + */ + if (!editor) return; + var table = inner_content.getElementsByTagName("table"); + for (var i=table.length-1; i >= 0; i-- ) + if (isChild(table(i))) return table(i); +} + +function selected_tr (mytable) { +/*------------------------------------------------------------ + * Return a number of current row + */ + var rows = mytable.rows; + for (var i=0; i < rows.length; i++) + if (isChild(rows(i))) return i; +} + +function selected_td (mytable,currentRow) { +/* ------------------------------------------------------------ + * Return a number of current column + */ + var cols = mytable.rows[currentRow].cells; + for (var i=0; i < cols.length; i++) + if (isChild(cols(i))) return i; +} + +function isChild(obj) { +/* ------------------------------------------------------------ + * Return 1: if the cursor is in an object area + */ + if (!controlRange) { + // selection is a TextRange + var rcts = obj.getClientRects(); + var selection = editor.selection.createRange(); + var sel_rcts = selection.getClientRects(); + var keyCount=0; + if ( (sel_rcts[keyCount].top >= rcts[keyCount].top) && (sel_rcts[keyCount].bottom <= rcts[keyCount].bottom) && (sel_rcts[keyCount].left >= rcts[keyCount].left) && (sel_rcts[keyCount].right <= rcts[keyCount].right) ) + return 1; + } +} + +function check_env() { + var mytable = selected_table(); + if (!mytable) return; + if ( selected_tr(mytable) >=0 ) return true; +} + +function check_merge(type) { + if (controlRange) return false; + htmlText = editor.selection.createRange().htmlText; + htmlText.toUpperCase(); + var ret = (type) ? ((htmlText.search(''s on Mozilla, 4 on IE, containing 20 's on + // Mozilla, 23 on IE. If anything is added or removed, this numbers MUST be + // updated added, this number should be incremented. + if (tbs.length < 3 || imgs.length < 19) { + initializing = false; + setTimeout("toolbarInit()", 100); + return; + } + if (parent.document.getElementById('load_bar')) { + parent.document.getElementById('load_bar').innerHTML = ''; + } + parent.document.getElementById('editor_iframe').style.visibility = "visible"; + tb = {}; + // 'toolbars' contains all the div tags + toolbars = []; + +// Go through the outerdoc and get the toolbar classes + for (var i = 0; i < tbs.length; i++) { + var toolbar = tbs[i]; + + tb[toolbar.title] = toolbar; + toolbars[toolbars.length] = toolbar; + + toolbar.TB_INDEX = toolbars.length; + +// Initialize the toolbar + tb_init(toolbar); + } + + tb_layout(); + + initialized = true; +} + +function tb_init (toolbar) { +/* --------------------------------------------------------- + * Called for each toolbar DIV. Populates the toolbar and + * sets the width. + */ + toolbar.TBWidth = 1; + tb_populate(toolbar) + + toolbar.style.posWidth = toolbar.TBWidth; + return true; +} + +function tb_populate (toolbar) { +/* --------------------------------------------------------- + * Moves all of toolbar 'toolbar's icons to the proper location on + * the screen and sets the correct size for the toolbars. + */ + + var elements = toolbar.childNodes; + if (!elements) return; +// Loop through all the toolbars children. + + for (var i = 0; i < elements.length; i++) { + var element = elements[i]; + if (element.tagName == "SCRIPT" || element.tagName == "!") continue; + +// Switch to see what element we are workin with. + switch (element.className) { + case "tb_menu_item": // A button + if (!element.INITIALIZED) + tb_init_button(element) + element.style.left = toolbar.TBWidth; + toolbar.TBWidth += element.offsetWidth + 1; + break; + + case "tb_general": // Not a button - most likely a form field + + case "tb_menu_text": + element.style.left = toolbar.TBWidth; + toolbar.TBWidth += element.offsetWidth + 5; + break; + + case "tb_sep": // Seperator + element.style.left = toolbar.TBWidth + 2; + toolbar.TBWidth += 5; + break; + + case "tb_handle": // Toolbar handle + element.style.left = 2; + toolbar.TBWidth += element.offsetWidth + 7; + break; + + default: // No action + } + } + + toolbar.TBWidth++; // Add 1 in case the width is zero + return true; +} + +function tb_init_button (element) { +/* --------------------------------------------------------- + * Sets up all the defaults for a button DIV. Saves any + * onclick and detaches the event. OnClick events are called + * onMouseDown. + */ + if (element.className == "tb_general") return true; + +// Set events + element.onmouseover = tb_mouseover; + element.onmouseout = tb_mouseout; + element.onmousedown = tb_mousedown; + element.onmouseup = tb_mouseup; + +// Save onClick event for onMouseDown + element.YUSERONCLICK = element.onclick; + +// So we don't re-initialize + element.INITIALIZED = true; + + return true; +} + +function tb_layout () { +/* --------------------------------------------------------- + * Layouts the toolbar on the screen based on the screen + * width and the widths built in tb_populate(). + */ + + if (!initializing && !initialized) return toolbarInit(); + + var num_tb = toolbars.length; + +// No toolbars + if (num_tb == 0) return; + var i; + +// Get the screen width minus the width of the scrollbar + var sbar = outerdoc.body.clientWidth - outerdoc.body.offsetWidth; + editorWidth = outerdoc.body.offsetWidth; + + var ScrWid = (outerdoc.body.offsetWidth - sbar) + (is_ie ? -6 : 7); + var ScrHit = (parent.document.getElementById('editor_iframe').offsetHeight - sbar) - (is_ie ? 6 : 5); + +// Go through the toolbars and find the width of the widest one. + var TotalLen = ScrWid; + var tb = []; + var e = 0; + for (i = 0; i < num_tb; i++) { + tb[e] = toolbars[i]; + if (tb[e].TBWidth > TotalLen) TotalLen = tb[e].TBWidth; + e++; + } + e--; + if (!tb.length) { return; } + var PrevTB; + var LastStart = 0; + var RelTop = 0; + var LastWid, CurrWid; + +// Position the top toolbar to the top of the screen + var TB = tb[0]; + TB.style.top = 0; + TB.style.left = 0; + var rows = 1; + +// Go through the toolbars and update their width and position. + var Start = TB.TBWidth; + var wExtra = 0 + var hExtra = 0; + + for (i = 1; i < tb.length; i++) { + PrevTB = TB; + TB = tb[i]; + CurrWid = TB.TBWidth; + +// Reached the end of the screen, reset to the start + if ((Start + CurrWid) > ScrWid) { + Start = 0; + rows++; + LastWid = TotalLen - LastStart + hExtra; + } + else { + LastWid = PrevTB.TBWidth; + RelTop -= TB.offsetHeight; + } + + TB.style.top = RelTop; + TB.style.left = Start; + PrevTB.style.width = LastWid; + + LastStart = Start; + Start += CurrWid; + + } + + outerdoc.getElementById('editor_iframe').style.top = rows * (is_ie ? 25 : 27); + outerdoc.getElementById('editor_iframe').style.height = ScrHit - rows * (is_ie ? 25 : 27) + wExtra; + outerdoc.getElementById('editor_iframe').style.width = ScrWid + wExtra; + outerdoc.getElementById('editor_iframe').style.visibility = 'visible'; +// Set the total width + TB.style.width = TotalLen - LastStart + hExtra; + +// Move the rest of the toolbars down + TB = tb[--i]; + var TBInd = TB.sourceIndex; + + var A = TB.childNodes; + for (var i in A) { + var item = A.item(i); + if (item && item.style && item.sourceIndex > TBInd && tb[item.title]) + item.style.posTop = RelTop; + } +} + +function tb_mouseover (event) { +/* --------------------------------------------------------- + * OnMouseOver event handler function for toolbar buttons. + */ + var image, element; + if ( is_ie ) { + event = parent.document.frames.editor_iframe.event; + + if (event.srcElement.tagName.toUpperCase() != "IMG") return cancel_event(event); + image = event.srcElement; + element = image.parentElement; + +// If we are in text mode and the button is disables for +// text mode. cancel the mouseover. + } + else { + image = outerdoc.getElementById(this.id + 'Image'); + element = this; + } + + if (element.disabled) return cancel_event(event); + +// If the image in normal state put it in mouseover state + if (image.className == "tb_icon") { + element.className = "menu_item_mouseoverup"; + } +// else if it is in down state put it in mouseover +// for down states. + else if (image.className == "icon_down") { + element.className = "menu_item_mouseoverdown"; + } + + return cancel_event(event); +} + +function tb_mouseout (event) { +/* --------------------------------------------------------- + * MouseOut event handler function for toolbar buttons + */ + // The source tag must be an image. + var image, element; + if ( is_ie ) { + event = parent.document.frames.editor_iframe.event; + if (event.srcElement.tagName != "IMG") return cancel_event(event); + var image = event.srcElement; + var element = image.parentElement; + + if (element.disabled) return cancel_event(event); + } + else { + image = outerdoc.getElementById(this.id + 'Image'); + element = this; + } + +// If the button is a toggle update it's state. + if (element.isPressed) { + element.className = "menu_item_mouseoverdown" + image.className = 'icon_down'; + } +// else put the image back to it's normal state. + else { + element.className = "tb_menu_item"; + image.className = "tb_icon"; + } + + return cancel_event(event); +} + +function tb_mousedown () { +/* --------------------------------------------------------- + * MouseDown event handler for toolbar buttons. + */ + this.className = 'menu_item_mouseoverdown'; +} + +function tb_mouseup () { +/* --------------------------------------------------------- + * MouseUp event handler function for toolbar buttons. + */ + this.className = 'menu_item_mouseoverup'; +} + +function isChanged() { +/*--------------------------------------------- +Return boolean, True if it's changed +*/ + var body = inner_content.innerHTML; + if (unStack.length == 0 || !body) return false; + else if (body != unStack[unStack.length-1]) return true; +} + +function getOffsetTop(elm) { + + var mOffsetTop = elm.offsetTop; + var mOffsetParent = elm.offsetParent; + + while(mOffsetParent){ + mOffsetTop += mOffsetParent.offsetTop; + mOffsetParent = mOffsetParent.offsetParent; + } + + return mOffsetTop; +} + +function getOffsetLeft(elm) { + + var mOffsetLeft = elm.offsetLeft; + var mOffsetParent = elm.offsetParent; + + while(mOffsetParent){ + mOffsetLeft += mOffsetParent.offsetLeft; + mOffsetParent = mOffsetParent.offsetParent; + } + + return mOffsetLeft; +} + +function insertNodeAtSelection (insertNode) { + if (is_ie) { + editor.selection.createRange().pasteHTML(insertNode.outerHTML) + return; + } + var win = document.getElementById("editor_iframe").contentWindow; + var sel = win.getSelection(); + + var range = sel.getRangeAt(0); + + // deselect everything + if (sel != '') + sel.removeAllRanges(); + + // remove content of current selection from document + range.deleteContents(); + + // get location of current selection + var container = range.startContainer; + var pos = range.startOffset; + + // make a new range for the new selection + range = document.createRange(); + + if (container.nodeType==3 && insertNode.nodeType==3) { + // if we insert text in a textnode, do optimized insertion + container.insertData(pos, insertNode.nodeValue); + + // put cursor after inserted text + range.setEnd(container, pos+insertNode.length); + range.setStart(container, pos+insertNode.length); + + } + else { + var afterNode; + if (container.nodeType==3) { + + var textNode = container; + container = textNode.parentNode; + var text = textNode.nodeValue; + + // text before the split + var textBefore = text.substr(0,pos); + // text after the split + var textAfter = text.substr(pos); + + var beforeNode = document.createTextNode(textBefore); + var afterNode = document.createTextNode(textAfter); + + // insert the 3 new nodes before the old one + container.insertBefore(afterNode, textNode); + container.insertBefore(insertNode, afterNode); + container.insertBefore(beforeNode, insertNode); + + // remove the old node + container.removeChild(textNode); + + } + else { + + // else simply insert the node + afterNode = container.childNodes[pos]; + container.insertBefore(insertNode, afterNode); + } + if (afterNode) { + range.setEnd(afterNode, 0); + range.setStart(afterNode, 0); + } + } + if (typeof(afterNode) != 'undefined') + sel.addRange(range); +} + +function cancel_event (event) { +/* --------------------------------------------------------- + * General function to cancel an event. + */ + if (!event) return false; + event.returnValue = false; + event.cancelBubble = true; + return false; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_button.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_button.html new file mode 100644 index 0000000..9bcaed5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_button.html @@ -0,0 +1,89 @@ + +Button + + + + + + + + + + + + + + + + + +
        Name:
        Value/label:
        Button type: + + + + + + +
        + Normal + + Submit + + Reset +
        +
        Tab order:
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_checkbox.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_checkbox.html new file mode 100644 index 0000000..0146359 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_checkbox.html @@ -0,0 +1,72 @@ + +Checkbox + + + + + + + + + + + + + + + + + +
        Name:
        Value:
        Initial State: + + + + + +
        + Selected + + Not Selected +
        +
        Tab order:
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_color.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_color.html new file mode 100644 index 0000000..517ec98 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_color.html @@ -0,0 +1,408 @@ + + + Color + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
                     
                     
                     
                     
                     
                     
                     
        +
        + + + + + + +
        +
        Sample
        +
        + + + + + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_dialog.css b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_dialog.css new file mode 100644 index 0000000..3711e34 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_dialog.css @@ -0,0 +1,53 @@ +/* ================================================================== + * Gossamer Threads Module Library - http://gossamer-threads.com/ + * + * dialog + * Author : Scott Beck + * $Id: editor_dialog.css,v 1.3 2004/01/23 00:47:15 bao Exp $ + * + * Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. + * ================================================================== + * + * Description: Style sheet for dialog pop-ups. + */ + +BODY { + font-family : "MS Sans Serif"; + font-size : 8pt; + background-color : buttonface; + margin : 0; +} + +TD { + font-family : "MS Sans Serif"; + font-size : 8pt; +} + +.sample { + font-family : "MS Sans Serif"; + border-left : buttonshadow solid 1px; + border-bottom : buttonhighlight solid 1px; + border-right : buttonhighlight solid 1px; + border-top : buttonshadow solid 1px; + overflow : hidden; + background-color : buttonface; +} + +.button { + font-family : "MS Sans Serif"; + background-color : buttonface; + font-size : 8pt; + width : 80px; +} + +select { + font-family : "MS Sans Serif"; + font-size : 8pt; + border-bottom : buttonhighlight solid 2px; + border-left : buttonshadow solid 2px; + border-right : buttonhighlight solid 2px; + border-top : buttonshadow solid 2px; + overflow : hidden; + cursor : default; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_editor.html new file mode 100644 index 0000000..5da50d2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_editor.html @@ -0,0 +1,15 @@ + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_font.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_font.html new file mode 100644 index 0000000..b7a7fd4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_font.html @@ -0,0 +1,313 @@ + +Select Font + + + + + + + + +
        Font:
        + + + +
         Effects 
        + +
        Underline
        + +
        Color:
        + + + +
        Style:
        + + + +
        Size:
        + + + +
         Sample 
        +
        AaBbYyZz
        + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_form.html new file mode 100644 index 0000000..2b6e719 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_form.html @@ -0,0 +1,53 @@ + +Insert Form + + + + + + + + + + + + + + + + + + +
        Name:
        Action:
        Method:
        Encoding Type:
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_iframe.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_iframe.html new file mode 100644 index 0000000..51070d3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_iframe.html @@ -0,0 +1,192 @@ + + + + +<%include editor_style.css%> + + + + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_image.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_image.html new file mode 100644 index 0000000..e4e0358 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_image.html @@ -0,0 +1,82 @@ + +Insert Image + + + + +
        + + + + + + + + + + + + + + + + + + + + + + +
        Source:
        + +
        Title: + +
        Width: + + Height:  + +
        Border: + + Alignment:  + +
        +
        + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_link.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_link.html new file mode 100644 index 0000000..f9bea46 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_link.html @@ -0,0 +1,20 @@ + +Create a Link + + + +
        + + + + + +
        URL:
        +
        + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_radio.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_radio.html new file mode 100644 index 0000000..09ef24d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_radio.html @@ -0,0 +1,70 @@ + +Radio + + + + + + + + + + + + + + + + + +
        Group Name:
        Value:
        Initial State: + + + + + +
        + Selected + + Not Selected +
        +
        Tab order:
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select.html new file mode 100644 index 0000000..8c0317c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select.html @@ -0,0 +1,317 @@ + +Insert Select Field + + + +
        + + + + + + + + + + + + +
        Name:  
        +
        + + + + + + + +
         ChoiceValueSelected
        +
        +
        +

        +

        +

        +

        +

        +
        + + + + + + + + + + + + + +
        Height: Allow multiple selections: Yes
        Tab order:   No
        +
         
        +
        +
        +   +   +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select_option.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select_option.html new file mode 100644 index 0000000..39aaf3b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_select_option.html @@ -0,0 +1,78 @@ + +Add Option + + + + + + + + + + + + + + +
        Option:
        Value:
        Selected: + Yes + No +
        +
        +
        +   + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_style.css b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_style.css new file mode 100644 index 0000000..5757526 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_style.css @@ -0,0 +1,125 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_table.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_table.html new file mode 100644 index 0000000..2bd6eba --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_table.html @@ -0,0 +1,51 @@ + +Create Table + + + + +
        + + + + + + + + + + + + + + + + + + + +
        Rows:Cell Padding:
        Columns:Cell spacing:
        WidthBorder:
        +
        +
        + +   +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_text.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_text.html new file mode 100644 index 0000000..2496637 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_text.html @@ -0,0 +1,64 @@ + +Insert Text Field + + + + + + + + + + + + +
        Name:
        Initial Value:
        +
        + + + + + + + + + + + + + +
        Width in characters:Tab Order:
        Password field:YesNo 
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_textarea.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_textarea.html new file mode 100644 index 0000000..7d10621 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/editor_textarea.html @@ -0,0 +1,66 @@ + +Insert textarea + + + + + + + + + + + + + + + + + + + + + + +
        Name:
        Initial Value:
        Cols:Rows:
        Tab Order:
        +
        +
        +   +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help.html new file mode 100644 index 0000000..4bc94ba --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help.html @@ -0,0 +1,303 @@ + + + + Gossamer FileMan - File Manager + + + + + + +
        +
        + +
        +
        +
        +
        +
        +

        Introduction

        +
        +

        Directory Structure

        +

        FileMan users who are unfamiliar with file management should read this section to gain a basic understanding of directories, paths, and other related concepts. Users who feel confident in their understanding of these concepts can proceed to the next three sections, which will deal with FileMan's structure and features.

        +

        File management is key to all computer systems, from basic home PC's to elaborate servers. A well-structured system of files not only enables you to find resources quickly and easily, but also lets you provide web access to files you wish to make accessible online.

        +

        Files are organized using directories (folders). Directories contain files and other directories. When using FileMan, you will have one root directory which will contain all other directories and files. It might help to visualize your directory structure as a sort of tree diagram, with directories and files "branching down" from your one root directory.

        +

        This illustration shows the structure of a hypothetical web domain account. In FileMan, as well as many other applications, file locations are specified using paths. Paths are strings of text that define the location of a file by providing the name of each directory and sub-directory (separated by forward slashes) that must be opened to find the file. Paths usually begin with a forward slash: /. The forward slash symbolizes the root directory. The path to the "currentlogo.jpg" file in this illustration would be:
        since the "currentlogo.jpg" file is found in the "logos" directory, found in the "images" folder which is itself located in the root directory.

        +

        FileMan allows you to view and manage your files using directories and paths. While managing files in FileMan, the path to a directory will be displayed in the Toolbar (see below for details), with all of the files and directories in that directory displayed in the Files menu (see below for details).

        +

        It is recommended that you do not use any blank spaces while naming directories or files; some web browsers cannot process them. It is also recommended that you do not use upper-case letters in directory and file names; paths are case sensitive online, and upper-case letters are usually avoided to avoid confusion.

        +
        +
        +
        +

        Interface

        +

        There are three main components of FileMan: the Toolbar (appears at the top of the page), the Files menu (the list of directories, files and statistics in the middle of the page) and the Actions menu (the drop-down menu at the top of the Files menu). While these three components do not operate separately from one another, they and their features will be discussed separately for the purposes of organization.

        +

        Figure 2
        A sample FileMan v.3 window.

        +

        The Files Menu

        +

        The Files Menu displays the files and directories in the directory you are viewing and provides detailed information about each of them through a series of columns. The checkboxes at the left of the Files Menu allows you to select files or directories for the commands found in the Actions menu (the drop-down menu displaying "More Actions" in the above screenshot). Clicking the checkbox at the top of the menu automatically selects all displayed files and directories.

        + +

        File Name

        +

        The file/folder name is listed in this column. Clicking the "Name" heading will sort the files and directories by file name in ascending order. Clicking the "Name" heading a second time will sort them in descending alphabetical order.

        +

        File Size

        +

        The file size of each file is listed in this column. Clicking the "Size" heading will sort the files and directories by file size in ascending order. Clicking the "Size" heading a second time will sort them in descending alphabetical order.

        +

        File Type

        +

        The file type of each file (directories are called "file folder"s) is listed in this column. Clicking the "File Type" heading will sort the files and directories by file type in ascending alphabetical order. Clicking the "File Type" heading a second time will sort them in descending alphabetical order.

        + +

        Modified

        +

        The date that each file or directory was last modified is listed in this column. Clicking the "Modified" heading will sort the files and directories by modification date in ascending order. Clicking the "Modified" heading a second time will sort them in descending alphabetical order.

        +

        Owner

        +

        The username of the owner of each file and directory is listed in this column. Clicking the "Owner" heading will sort the files and directories by owner in ascending alphabetical order. Clicking the "Owner" heading a second time will sort them in descending alphabetical order.

        +

        Permissions

        +

        The permission settings of each file and directory are listed in this column. Clicking the "Permissions" heading will sort the files and directories by permission settings in ascending alphabetical order. Clicking the "Permissions" heading a second time will sort them in descending alphabetical order. Clicking on the permission settings of a specific file or directory will display a form allowing you to modify the file or directory's permission settings by checking individual permissions or by entering the numeric code for the desired permissions. If you need more information, a tutorial explaining how to configure permissions is available here: http://www.itc.virginia.edu/desktop/web/permissions/

        + +

        The Toolbar

        +

        The Toolbar displays the directory location you are currently viewing in FileMan, as well as a series of tools that allow you to manage your files. Click on "The Toolbar" in the navigation menu at the left of this help page for information on specific Toolbar functions.

        +

        In the top left corner of the Toolbar, the location of the directory you are currently viewing will be displayed; /templates/luna would be a possible location. Thus, all files and directories in that location will be displayed in the Files menu (see below for details). You can click on any of the directory names listed in the location to view a specific directory.

        +

        Figure 3
        The Toolbar.

        +

        The text field in the top right corner of the Toolbar allows you to open a directory found in the location currently being displayed. If you are viewing a directory which contains another directory called "images", for example, entering "images" in the field and clicking "Go" will open the "images" directory and display its contents in the Files menu.

        +

        The Actions Menu

        + +

        The Actions Menu drops-down to allow you to perform various actions on files and directories you select via checkboxes in the Files Menu. Click on "The Actions" in the navigation menu at the left of this help page for information on specific actions.

        +

        Figure 2
        The Actions Menu.

        + +

        Multi-User Version

        +

        Figure 7

        +

        The multi-user version of FileMan v.3 features a dropdown menu for directories, allowing users to choose which path they wish to work in. Simply click on the down-pointing green arrow beside the directory name and a list of accessible directories will appear.

        +

        Access to these directories is defined by the admin in the "Users Manager" option in the Tools link. Enter the paths to the directories that you want the user to have access to in the "Access Directories" section.

        + +

        Logout

        +

        Clicking the "Logout" link will sign you out of your current FileMan session and return you to the login page.

        +
        +
        +

        The Toolbar

        +

        Toolbar

        +

        The commands available to you in the Toolbar are your primary methods of managing the files and directories on your FileMan installation. Click on the names of specific commands to learn more about them individually.

        +
        +
        +

        Actions

        +

        Action Bar

        +

        The Command Bar allows you to perform commands and actions upon files and directories that you have selected in the Files menu. Each action is listed in the "More Actions" dropdown menu.

        +
        +
        +

        Settings

        +

        search

        +

        Clicking the "Settings" link displays a drop-down list of sub-menus allowing you to customize your FileMan installation.

        +
        +
        +

        Setup

        + <%include help_setup.html%> +
        +
        +

        Change Password

        + <%include help_password.html%> +
        +
        +

        Preferences

        + <%include help_preferences.html%> +
        +
        +

        Users Managerment

        + <%include help_user.html%> +
        +
        +

        Browser Logs

        + <%include help_logs.html%> +
        +
        +

        Environment

        +

        The "Environment" link displays a detailed list of system information about your FileMan installation. This list can be useful for identifying system errors.

        +
        + +
        +

        Replace

        +

        search

        + <%include help_replace.html%> +
        +
        +

        Command

        +

        search

        + <%include help_command.html%> +
        +
        +

        Upload

        +

        search

        + <%include help_upload.html%> +
        +
        +

        New File

        +

        New file

        + <%include help_file.html%> +
        +
        +

        New Folder

        +

        New Folder

        + <%include help_makedir.html%> +
        +
        +

        Protect

        +

        search

        + <%include help_protect.html%> +
        +
        +

        Download

        + <%include help_download.html%> +
        + +
        +

        Copy

        +

        command bar + <%include help_copy.html%> +

        +
        +

        Move

        +

        command bar + <%include help_move.html%> +

        +
        +

        Rename

        +

        command bar + <%include help_rename.html%> +

        +
        +

        Delete

        +

        command bar +

        After checking off one or more files or directories, selecting the "Delete" option will permanently delete them. If you've selected multiple files, you can choose to skip the deletion of individual files you've mistakenly checked, or to delete all files simultaneously.

        +
        +
        +

        Compress

        +

        command bar + <%include help_compress.html%> +

        +
        +

        Uncompress

        +

        command bar + <%include help_uncompress.html%> +

        +
        +

        Chmod

        +

        command bar + <%include help_chmod.html%> +

        +
        +

        Perl Check

        + <%include help_perl.html%> +
        +
        +

        Tail

        + <%include help_tail.html%> +
        +
        +

        Diff

        + <%include help_diff.html%> +
        +
        +

        Print

        +

        After selecting one or more files, selecting the "Print" link will open a window displaying a preview of the file's printed appearance, as well as your regular print window. If you select multiple files to be printed, you will be given the option of printing them separately or as one document.

        +
        +
        +
        +
        +
        +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_chmod.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_chmod.html new file mode 100644 index 0000000..2a2c5c1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_chmod.html @@ -0,0 +1,2 @@ +

        Chmod allows you to specify the permissions for selected item(s), setting them as writable, readable, executable, etc. Simply check off the actions you want or if you know the Chmod number, enter it in the 'as numerical' field and click 'Chmod'.

        +

        If you need more information, a tutorial explaining how to configure permissions is available here: http://www.itc.virginia.edu/desktop/web/permissions/

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_command.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_command.html new file mode 100644 index 0000000..d8b7c30 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_command.html @@ -0,0 +1,5 @@ +

        +Enter the command you wish to execute in the "Command" field and click the "Execute " button. You can also execute a file by checking the box beside the desired file in the Files Menu and clicking the "Execute" button.

        +

        +If you are running a command or file that will take more than ten seconds, checking the "Long Running" box will ensure that your command will not time out. +

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_compress.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_compress.html new file mode 100644 index 0000000..482b913 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_compress.html @@ -0,0 +1,7 @@ +

        You can compress one or more files or directories, into a single compressed file -- in a variety of formats.

        +
          +
        • Check off all the files and/or directories you wish to include in the compressed file
        • +
        • Select the desired compression format from the drop-down menu. Choose from .tar, .tar.gz and .zip.
        • +
        • Enter the path to the directory you wish to save the file in and give it a filename in the field provided. For example, selecting .tar and entering /images/foo in the field would save the compressed files as foo.tar in your images directory.
        • +
        • Click 'Create File'
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_copy.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_copy.html new file mode 100644 index 0000000..9dbcf2a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_copy.html @@ -0,0 +1 @@ +

        After checking off one or more files or directories, enter the path to the directory you wish to copy the item(s) to, and click the 'Copy' button.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_diff.html new file mode 100644 index 0000000..2ea927a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_diff.html @@ -0,0 +1,10 @@ +

        The "Diff" option allows you to compare the file's content with that of another, and have the differences between the two displayed. This option will only work for text-based files, such as .txt or .html files and is useful when reviewing files that are often updated.

        +
          +
        • Enter the filename or the path to the second file (or click "Browse" to select a path) to be compared to and click the 'Diff' button. (Eg. '/templates/luna/version2.html')
        • +
        • The differences between the two files will be displayed in a new screen. +
            +
          • Lines that are prefaced by a minus sign (-) are lines which appear in the first file but not in the second.
          • +
          • Lines that are prefaced by a plus sign (+) are lines which appear in the second file but not in the first.
          • +
          +
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_download.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_download.html new file mode 100644 index 0000000..b624819 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_download.html @@ -0,0 +1,12 @@ +

        You can download selected items or directories in various file and compression formats.

        +
          +
        • Choose the format of the item(s) you are downloading in the "Mode" drop-down menu. Choose between Ascii, Binary and Auto: +
            +
          • Ascii format should be used for files that use plain text with no formatting
          • +
          • Binary should be used for all other types of files
          • +
          • Auto will automatically determine which format to use; you will usually not need to specify either Ascii or binary
          • +
          +
        • +
        • If you wish to download the item(s) in a compressed format, select the desired compression format (which should be indicated by the file extensions) from the "Compressed type" drop-down menu. Choose from None, .tar, .tar.gz and .zip. Note: if you are downloading multiple items, you will have to select a compression type.
        • +
        • Click the 'Download' button to download your selected file(s).
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_file.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_file.html new file mode 100644 index 0000000..44fb927 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_file.html @@ -0,0 +1,7 @@ +

        Clicking the "New File" button allows you to create a new file that will be saved in the directory you are currently viewing.

        +
          +
        • Enter the contents of the new file
        • +
        • Enter a file name with the appropriate extension in the field provided (EG. .txt, .html, .php)
        • +
        • Click the 'Save' button. Your new file will now appear in the directory
        • +
        +

        By default, the text editor will be displayed. Clicking the "Switch to HTML" button will allow you to create detailed HTML pages using a feature-rich HTML editor.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_logs.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_logs.html new file mode 100644 index 0000000..95327d4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_logs.html @@ -0,0 +1,8 @@ +

        "Browser Logs" allow you to review all commands and activities performed on FileMan by all of your installations users.

        +
          +
        • By default the most recent 25 activities/commands are displayed.
        • +
        • To search, select the "Search" option in the dropdown menu. You can refine your search for specific commands by selecting a time frame, a specific action or a specific user to search for.
        • +
        • In the Action drop-down, you can choose what type of action you would like to search for. If the "Match Any" box is checked the search will return all commands containing any of the search criteria entered in the search form. For example, a "Match Any" search for commands performed in the last two weeks and "user1" in the Username field would return all commands performed in the last two weeks, even if they were not performed by user1, and vice versa.
        • +
        • The currently displayed list of browser log entries can be deleted by selecting "Clear Logs" in the drop-down menu.
        • +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_makedir.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_makedir.html new file mode 100644 index 0000000..e001989 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_makedir.html @@ -0,0 +1,4 @@ +

        Clicking the "New Folder" link in the Toolbar allows you to create a new folder within the directory you are currently viewing.

        +

        +Enter a name for the new folder in the field provided and click the 'Create' button. Your new folder will now be displayed in the directory. +

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_move.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_move.html new file mode 100644 index 0000000..ba289cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_move.html @@ -0,0 +1,2 @@ +

        After checking off one or more files or directories, selecting the "Move" option allows you to specify a directory to which the selected item(s) will be moved.

        +

        Enter the path to the directory you wish to move the item(s) to, or click the Browse button to choose a directory, and and click the 'Move' button.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_password.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_password.html new file mode 100644 index 0000000..e7bd328 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_password.html @@ -0,0 +1,2 @@ +

        The "Change Password" menu allows you to change your FileMan password.

        +

        Please make sure to pick a secure password that you can remember easily.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_perl.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_perl.html new file mode 100644 index 0000000..89db097 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_perl.html @@ -0,0 +1,2 @@ +

        After checking off a single file, selecting the "Perl" option will check the syntax of perl files to ensure that the syntax is correct.

        +

        This function will only work if the selected file is a Perl file. diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_preferences.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_preferences.html new file mode 100644 index 0000000..ee2b46b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_preferences.html @@ -0,0 +1,11 @@ +

        The Preferences menu allows you to set account-specific preferences; each user can customize their own preferences.

        +
          +
        • Working Path: This field allows you to specify the path that will be displayed by default when you login.
        • +
        • Password Directory: This field should contain the path to the directory where your .htaccess file (which stores passwords created with the Protect option) is stored.
        • +
        • Sort By: Specify the order in which your files and directories will be sorted and displayed by choosing a criteria (Name, Size, Type, Modified, Owner, Permissions) and either descending or ascending order. Note that directories will always be displayed above files.
        • +
        • Max Hits: Choose the number of files and directories that will be displayed per page.
        • +
        • Hidden Files: Choose whether or not to display hidden files while viewing directories.
        • +
        • Editor Mode: Choose whether the plain Text editor or the HTML editor will be displayed by default when you are editing or creating new files.
        • +
        • Effects: Choose whether to use visual effects for various Fileman menus and alerts.
        • +
        • The README's Content: Choose whether README files (which are automatically displayed when a directory is being viewed) above or below the directory structure.
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_protect.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_protect.html new file mode 100644 index 0000000..24e2036 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_protect.html @@ -0,0 +1,12 @@ +

        Clicking the "Protect" link in the Toolbar will display a form at the top of the page allowing you to protect the directory you are currently viewing by configuring a username and password that will be required to access it.

        +
          +
        • Enter a "User name" and "Password" in the fields provided.
        • +
        • Options: +
            +
          • Overwrite: will overwrite an existing user with the username and password.
          • +
          • MD5 password: generate an md5 password that's compatible with Apache.
          • +
          +
        • Click the "Add User" button. The user name and password will now have to be entered to access the directory currently being viewed.
        • +
        • Existing user names and passwords can be deleted by selecting the desired user name from the drop-down menu and clicking the "Remove" button or by clicking the "Remove All" button.
        • +
        +

        Once a username and password has be created, the url of the directory cannot be viewable from a browser without correctly providing the designated username and password. (EG. if you protected the directory 'foo', the url www.yoursitename.com/foo cannot be accessed without a username and password)

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_rename.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_rename.html new file mode 100644 index 0000000..269797f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_rename.html @@ -0,0 +1,2 @@ +

        After checking off a file or directory, selecting the "Rename" option allows you to specify a directory to which the selected item will be rename.

        +

        Enter the new name you wish to rename the item, and click the 'Rename' button.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_replace.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_replace.html new file mode 100644 index 0000000..4a7840a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_replace.html @@ -0,0 +1,7 @@ +

        Clicking the "Replace" link in the Toolbar will display a form at the top of the page allowing you to search within files for a specific string of text and replace it with a new string of text. Simply check the box of the file you wish to perform the replace function on, enter the string you wish to replace, enter the string you wish to replace it with, and click replace.

        +
          +
        • The "Replace" drop-down menu allows you to choose whether you wish to search the entire directory you are viewing for the string you wish to replace, or only selected files and subdirectories within that directory (select these files and directories by clicking the checkboxes beside them in the Files menu). Note that directories "above" the one you are viewing cannot be searched for strings to replace; searching a directory named "images" in the root directory will not search any of the other directories and files in the root directory.
        • +
        • Choose whether or not your search for strings will be "case sensitive" using the checkbox provided.
        • +
        • Choose whether or not you wish to search using a regular expression with the "Regular Expression" checkbox provided. This allows users with some knowledge of regular expressions to search for files with content meeting specified criteria. Clicking the "Regular Expression" checkbox will automatically check the "Search Contents" box.
        • +
        • If you choose to "Create .bak," a backup file containing the original string of text will be created in the same directory as any files that were modified by the replacement. If, for example, you had a file named "colour.txt" containing the word "blue", and you used the replace option to substitute "blue" with "red" with the "Create .bak file" option enabled, two files would now appear in the directory that "colour.txt" is located in: a "colour.txt" file containing the word "red", and a "colour.txt.bk" file containing the word "blue".
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_search.html new file mode 100644 index 0000000..2b448ef --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_search.html @@ -0,0 +1,8 @@ +

        Clicking the "Search" link in the Toolbar allows you to search for specific files or directories.

        +
          +
        • The "Search" drop-down menu allows you to choose whether you wish to search the entire directory you are viewing, or only selected files and subdirectories within that directory (select these files and directories by clicking the checkboxes beside them in the Files menu). Note that directories "above" the one you are viewing cannot be searched; searching a directory named "images" in the root directory will not search any of the other directories and files in the root directory.
        • +
        • Choose whether or not your search will be "case sensitive" using the checkbox provided.
        • +
        • Choose whether or not you wish to search using a regular expression with the "Regular Expression" checkbox provided. This allows users with some knowledge of regular expressions to search for files with content meeting specified criteria. Clicking the "Regular Expression" checkbox will automatically check the "Search Contents" box.
        • +
        • Choose whether to search the contents of files in the directory you are searching with the "Search Contents" checkbox provided. If you are searching a directory with a text file called "test.txt", which itself contains the string "this is a test", searching for "this is" will only return "test.txt" if the "Search Contents" function is enabled.
        • +
        • Clicking the "Advanced Search" link will open a new window allowing you to further refine your search parameters. You will be able to select a file type to search for, define search terms in the file name and the file's contents, as well as how recently the file was modified. If you are defining a date range in which you wish to search, click the ".." buttons beside each field to open a calendar menu. You will be able to scroll through the calendar and click the appropriate dates in order to enter the dates in the proper format.
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_setup.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_setup.html new file mode 100644 index 0000000..6ae543c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_setup.html @@ -0,0 +1,19 @@ +

        The Setup menu allows you to view and modify your FileMan URLs and paths, as well as general administrative settings.

        +
          +
        • CGI URL: This field should contain the URL of the directory where your admin files, such as FileMan.cgi, are located.
        • +
        • Static URL: This field should contain the URL of the directory where your CSS and Javascript are located.
        • +
        • Root Directory: This field should contain the path to the root directory of your installation.
        • +
        • Password Directory: This option allows you to choose whether or not users will be able to save their passwords (as controlled by the "Password Directory" option in the Preferences menu) outside of the root directory.
        • +
        • Admin E-mail: The address to which all administrative mail will be sent. +
        • SMTP Server: The SMTP server which will be used to send all FileMan related mail. Enter a value in this field or in the "sendmail Path" option below, but not both. +
        • sendmail Path: The path to the mail server which will be used to send all FileMan related mail. Enter a value in this field or in the "SMTP Server" option above, but not both. +
        • Date Output Format: This field controls the format that will be used when displaying date and time information in logs and in the main File Menu. +
        • Date Input Format: This field controls the format that FileMan will require users to use while searching for files by date and time criteria. +
        • Keep Log: Configure the number of days that access information will be saved in order to be displayed in the Browser Log.
        • +
        • Cookie Name: Select a cookie name and enter the amount of time after which cookies will expire.
        • +
        • File Name Check: This option determines whether or not files being uploaded or created will be checked for proper title syntax; if enabled, file names including spaces and other special characters will not be allowed.
        • +
        • Debug: This option allows you to enable and disable debug mode, in which large amounts of debug information will be added to the FileMan.config file. Note: debug mode should only be enabled when you are doing system maintenance. Debug mode creates significant amounts of overhead, adds large amounts of debug code to the error log and may allow users to obtain access to the server. Make sure to disable it when finished.
        • +
        • Upload Mode: This field contains the permission settings that will be used for all uploaded files.
        • +
        • Allowed Space: This field controls the default number of bytes that will be the limit for each new user (this value can be changed when creating and editing users).
        • +
        • Permissions: In these menus you can select which tools and commands new users will be able to access and execute by default.
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_symlink.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_symlink.html new file mode 100644 index 0000000..bac1409 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_symlink.html @@ -0,0 +1,2 @@ +

        After checking off one or more files or directories, selecting the "Symlink" option displays a menu allowing you to create a symlink to the selected files and directories.

        +

        Enter a path to an existing location on your installation and click 'Create Symlink.' If you've selected multiple files or directories, separate symlinks will be displayed for each at the specified location.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_tail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_tail.html new file mode 100644 index 0000000..2ca7b52 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_tail.html @@ -0,0 +1,5 @@ +

        After selecting a single file, clicking the "Tail" link displays a menu allowing you to configure a screen that will show the last lines of that file.

        +
          +
        • Enter how many of the file's last lines you wish to view in the "Number of lines" field. If you want the tail screen to automatically refresh while you are viewing it, choose a refresh rate (in seconds) from the drop-down menu. This option can be useful when you wish to view access and error logs as they are being generated.
        • +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_uncompress.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_uncompress.html new file mode 100644 index 0000000..461b22b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_uncompress.html @@ -0,0 +1,6 @@ +

        After clicking on a compressed file format (.zip, .tar, .tar.gz), you'll be brought to a screen that gives you the option to uncompress all or selected files.

        +
          +
        • Select your option in the dropdown menu and if you wish, type in a directory to uncompress to
        • +
        • Click 'Uncompress' to extract your selected files
        • +
        +

        Note: If no directory is chosen, the selected files will be extracted to whatever directory the compressed file resides in.

        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_upload.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_upload.html new file mode 100644 index 0000000..286be61 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_upload.html @@ -0,0 +1,8 @@ +

        Clicking the "Upload" link in the Toolbar will allow you to upload files to the directory you are currently viewing.

        +
          +
        • Click the "Browse" button to select a file, or simply enter the path to the desired file in the "File" field.
        • +
        • You can select the format of the file you wish to upload: choose Ascii, Binary or Auto. Ascii format should be used for files that use plain text with no formatting, binary should be used for all other types of files. The auto option will automatically determine which format to use; you will usually not need to specify either Ascii or binary.
        • +
        • If you wish to overwrite existing files with newly uploaded files that have the same name, check the "Overwrite" box, otherwise an error message will appear.
        • +
        • If you wish to upload multiple files at the same time, click the "Multiple Upload" link to see a menu allowing you to specify up to ten files at a time.
        • +
        • Click the 'Upload button to upload the file to the directory.
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_user.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_user.html new file mode 100644 index 0000000..9a1cf5d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/common/help_user.html @@ -0,0 +1,17 @@ +

        The "Users Manager" allows you to view, create and modify user accounts on your FileMan installation.

        +
          +
        • Existing users' information can be edited by clicking on the names themselves.
        • +
        • The "Access Directories" column displays paths to all directories the user has access to. To change user permissions and accesses, check off a user and select an option in the dropdown menu.
        • +
        • + Clicking the "New User" button will display a menu allowing you to define all aspects of a new user record. +
            +
          • Enter the user's name, password and e-mail address.
          • +
          • Choose whether the user will have access to administrative options, or the standard user ones by choosing "User" or "Administrator" in the drop-down menu.
          • +
          • Enter the directory where the user's root access will be (?). Choosing "Add a User" from the drop-down menu will allow you to select an existing folder, or you can check the "Create User Directory" box to automatically (?) create a directory for the user.
          • +
          • Enter the allowed space (in kilobytes) the user will be given in their directory, or enter "0" to not create a limit.
          • +
          • If you wish to customize which tools and commands the user has access to, check or uncheck the desired ones (the default tools/commands settings are defined in the Setup menu).
          • +
          +
        • +
        • You can define tools and commands permissions for multiple users at a time by checking them and selecting "Change Permissions" in the drop-down menu. Any changes you make will be applied to all selected users.
        • +
        • You can define directory access for multiple users at a time by checking them and and selecting "Change Access" in the drop-down menu. Check the directories you wish to give access to for all selected users.
        • +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/confirm_delete.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/confirm_delete.html new file mode 100644 index 0000000..8a328b7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/confirm_delete.html @@ -0,0 +1,57 @@ + + +
        + +
        + + + +
        + + + + + +
         Confirm   + +
        + + + + + + +
        <%font%>
        Do you want to remove all child files and directories in this directories?
        <%font%>
        <%file_cur%>

        + + + +

        +
        +
        +
        +<%loop list_files%> + +<%endloop%> + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/copy_status.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/copy_status.html new file mode 100644 index 0000000..70fb508 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/copy_status.html @@ -0,0 +1,3 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor.html new file mode 100644 index 0000000..e5e66f4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor.html @@ -0,0 +1,168 @@ + + +FileMan + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%ifnot user_sessions%> + + + <%endif%> + <%if root_selected%> + + <%endif%> + +
        + + + + + +
         File Editor  <%if filename%><%filename%><%endif%>
        + + + + + <%if msg%> + + + + <%endif%> + <%if use_html%> + + + + <%else%> + + + + + + + <%endif%> +
        + + <%if old%> + + + <%else%> + + + <%endif%> + <%if ie_version >= 5.5 or mozilla_version >= 1.4%> + + <%endif%> + +
        <%font%> + <%if writeable%><%else%>(Not Writeable)<%endif%> - + + + +
        <%font%>File name:  + + +
        +
        <%font%><%msg%>
        <%include file_html_editor.html%>
        + + +
        + + + + <%if is_ie%> + + <%endif%> + +
        <%font%> + <%if is_ie%><%endif%> + +   rows + + <%font%>Line: +
        +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor_confirm.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor_confirm.html new file mode 100644 index 0000000..5c108c4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_editor_confirm.html @@ -0,0 +1,50 @@ + + +
        + +
        + + + +
        + + + + + +
         File editor confirm 
        + + + + +
        <%font%>
        <%filename%> file already exists, do you want to overwrite it?

        + +

        +
        +
        +
        + + + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_html_editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_html_editor.html new file mode 100644 index 0000000..7ac997c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/file_html_editor.html @@ -0,0 +1,31 @@ + + + + + + +
        <%font%>Loading...
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/help_fileman.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/help_fileman.html new file mode 100644 index 0000000..94ee7d8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/help_fileman.html @@ -0,0 +1,373 @@ + + + +FileMan Help + + + + + +
        +
        +

        FileMan Help
        +Note: This help page is based on FileMan help documentation originally written by Paula Edminston: edminston@matrixmagic.com.

        + +Overview
        +

        File Management: An Introduction


        +FileMan
        +    The Toolbar
        +        Search
        +        Replace
        +        Command
        +        Upload
        +        New File
        +        New Dir
        +        Protect
        +        Prefs
        +        Password
        +        Log Off
        +    The Files Menu
        +        View
        +        Name
        +        Size
        +        File Type
        +        Modified
        +        Owner
        +        Permissions
        +    The Command Bar
        +        Edit
        +        Download
        +        Copy
        +        Delete
        +        Move
        +        Chmod
        +        Tail
        +        Perl
        +        Diff
        +        Compress
        +        Print

        + +

        Overview +


        +
        +FileMan is a web-based file manager that allows you to completely manage a website without the need for FTP or Shell access. FileMan provides you with numerous management options not found in FTP programs, but unlike FTP programs is designed solely for personal web management (meaning that remote domains cannot be accessed).

        + +

        File Management: An Introduction


        +FileMan users who are unfamiliar with file management should read this section to gain a basic understanding of directories, paths, and other related concepts. Users who feel confident in their understanding of these concepts can proceed to the next three sections, which will deal with FileMan’s structure and features.

        + +

        File management is key to all computer systems, from basic home PC’s to elaborate servers. A well-structured system of files not only enables you to find resources quickly and easily, but also lets you provide web access to files you wish to make accessible online.

        + +

        Files are organized using directories (folders). Directories contain files and other directories. When using FileMan, you will have one root directory which will contain all other directories and files. It might help to visualize your directory structure as a sort of tree diagram, with directories and files “branching down” from your one root directory.

        + +

        +
        Figure 1: A sample directory structure.

        + +

        This illustration shows the structure of a hypothetical web domain account. In FileMan, as well as many other applications, file locations are specified using paths. Paths are strings of text that define the location of a file by providing the name of each directory and sub-directory (separated by forward slashes) that must be sequentially opened to find the file. Paths usually begin with a forward slash: /. The forward slash symbolizes the root directory. The path to the “currentlogo.jpg” file in this illustration would be: + +

        /images/logos/currentlogo.jpg

        + +

        since the “currentlogo.jpg” file is found in the “logos” directory, found in the “images” which is itself located in the root directory.

        + +

        FileMan allows you to view and manage your files using directories and paths. While managing files in FileMan, the path to a directory will be displayed in the Toolbar, with all of the files and directories in that directory displayed in the Files Menu.

        + +

        Note: You cannot use any blank spaces while naming directories or files. It is also recommended that you do not use upper-case letters in directory and file names; paths are case sensitive online, and upper-case letters are usually avoided to avoid confusion.

        + +

        FileMan



        + +

        +
        Figure 2: A sample FileMan window.

        + +

        There are three main components of FileMan: the Toolbar (displayed at the top of the page), the Files Menu (the list of directories, files and statistics in the middle of the page) and the Command Bar (displayed at the bottom of the page). While these three components do not operate separately from one another, they and their features will be discussed separately for the purposes of organization. + +

        The Toolbar



        +The Toolbar provides you with the location you are currently viewing in FileMan, as well as a series of tools that allow you to manage your files.

        + +

        +
        Figure 3: The Toolbar.

        + +

        In the top left corner of the Toolbar, the location of the directory you are currently viewing will be displayed; /GT/FileMan is being displayed in the example above. Thus, all files and directories in that location will be displayed in the Files Menu. You can click on of the directory names listed to view that directory.

        + +

        The “Directory:” field in the top right corner of the Toolbar allows you to open a directory found in the location currently being displayed (thus, this box acts like a "cd" command). If you are viewing a directory which contains another directory called “images”, for example, entering “images” in the “Directory:” field and clicking “Go” will open the “images” directory and display its contents in the Files menu. If you wish, you can also enter a multi-directory path in the "Directory:" field, such as "images/logos"

        + +

        Search
        +Clicking the “Search” link in the Toolbar will display a search form at the bottom of the page allowing you to search for specific files or directories.

        + +

        +
        Figure 4: The Search form.

        + +

        -The “Look in:” drop-down menu allows you to choose whether you wish to search the entire directory you are viewing, or only selected files and subdirectories within that directory (select these files and directories by clicking the checkboxes beside them in the Files menu). Note that directories “above” the one you are viewing cannot be searched; searching a directory named “images” in the root directory will not search any of the other directories and files in the root directory.

        + +

        -Choose whether or not your search will be “case sensitive” using the checkbox provided.

        + +

        -Choose whether to search the contents of files in the directory you are searching with the “Search Contents” checkbox provided. If you are searching a directory with a text file called “test.txt”, which itself contains the string “this is a test”, searching for “this is” will only return “test.txt” if the “Search Contents” function is enabled.

        + +

        -Choose whether or not you wish to search using a regular expression with the “Expression” checkbox provided. This allows users with some knowledge of regular expressions to search for files with content meeting specified criteria. Clicking the “Expression” checkbox will automatically check the “Search Contents” box.

        + +

        Replace
        +Clicking the “Replace” link in the Toolbar will display a form at the bottom of the page allowing you to search for a specific string of text and replace it with a new string of text. Note: This option only works on .txt files.

        + +

        +
        Figure 5: The Replace form.

        + +

        -The “Look in:” drop-down menu allows you to choose whether you wish to search the entire directory you are viewing for the string you wish to replace, or only selected files and subdirectories within that directory (select these files and directories by clicking the checkboxes beside them in the Files menu). Note that directories “above” the one you are viewing cannot be searched for strings to replace; searching a directory named “images” in the root directory will not search any of the other directories and files in the root directory.

        + +

        -Choose whether or not your search for strings will be “case sensitive” using the checkbox provided.

        + +

        -Choose whether or not you wish to search using a regular expression with the “Expression” checkbox provided. This allows users with some knowledge of regular expressions to search for files with content meeting specified criteria. Clicking the “Expression” checkbox will automatically check the “Search Contents” box.

        + +

        -Choose whether your search will return and replace “Whole words only” with the checkbox provided. A “whole word only” search for “test” would not return any instances of the words “testing” or “tester”, for example.

        + +

        -If you choose to “Create .bak file”, a backup file containing the original contents of the file before replacement will be created in the same directory as any files that were modified by the replacement. If, for example, you had a file named “colour.txt” containing the word “blue”, and you used the replace option to substitute “blue” with “red” with the “Create .bak file” option enabled, two files would now appear in the directory that “colour.txt” is located in: a “colour.txt” file containing the word “red”, and a “colour.txt.bk” file containing the word “blue”.

        + +

        Command
        +Clicking the “Command” link in the Toolbar will display a form at the bottom of the page allowing you to execute a specified command or run a specified file.

        + +

        +
        Figure 6: The Command form.

        + +

        Enter the command you wish to execute in the “Command” field and click the “Execute” button. You can also execute a file by checking the box beside the desired file in the Files Menu and clicking the “Run selected file” button. If you are running a command or file that will take more than ten seconds, checking the “Long Running” box will ensure that your command will not time out.

        + +

        Upload
        +Clicking the “Upload” link in the Toolbar will display a form at the bottom of the page allowing you to upload a file to the directory you are currently viewing.

        + +

        +
        Figure 7: The Upload form.

        + +

        -The current directory that the file will be uploaded to is displayed at the top of the form.

        + +

        -Click the “Browse…” button to select a file, or simply enter the path to the desired file in the “File name:” field.

        + +

        -You can select the format of the file you wish to upload: choose Ascii, Binary or Auto. Ascii format should be used for files that use plain text with no formatting, binary should be used for all other types of files. The auto option will automatically determine which format to use; you will usually not need to specify either Ascii or binary.

        + +

        -If you wish to overwrite existing files with newly uploaded files that have the same name, check the “Overwrite” box, otherwise an error message will appear.

        + +

        -If you wish to upload multiple files at the same time, click the “Multiple Upload” link to see a menu allowing you to specify up to ten files at a time.

        + +

        -Click the “Upload” button to upload the file to the directory.

        + +

        New File
        +Clicking the “New File” link in the Toolbar displays a form in the Files menu allowing you to create a new file that will be saved in the directory you are currently viewing.

        + +

        +
        Figure 8: The New File form.

        + +

        -By default, the HTML editor will be displayed. The HTML editor allows you to enter formatted text (such as bolded or coloured text as well as multiple fonts) and URLs without using any tags. You can switch to plain text if you prefer by clicking the “Switch to Text” button. Note: The HTML editor will only function in Internet Explorer 5.5 or later. Netscape and earlier versions of IE will only be able to use the plain text editor.

        + +

        -Enter the contents of the new file.

        + +

        -Enter a file name with the appropriate extension in the field provided, and click the “Save document” button. Your new file will now appear in the directory.

        + +

        New Dir
        +Clicking the “New Dir” link in the Toolbar will display a form at the bottom of the page allowing you to create a new directory within the directory you are currently viewing.

        + +

        +
        Figure 9: The New Directory form.

        + +

        -Enter a name for the new directory in the field provided and click the “Create” button. Your new directory will now be displayed in the Files menu.

        + +

        Protect
        +Clicking the “Protect” link in the Toolbar will display a form at the bottom of the page allowing you to protect the directory you are currently viewing by configuring a username and password that will be required to access it. Note: This option will not work if FileMan is running on a Windows server.

        + +

        +
        Figure 10: The directory protection form.

        + +

        -Enter a “User name” and “Password” in the fields provided.

        + +

        -Click the “Add User” button. The user name and password will now have to be entered to access the directory currently being viewed.

        + +

        -Existing user names and passwords can be deleted by selecting the desired user name from the drop-down menu and clicking the “Remove” button or by clicking the “Remove All” button.

        + +

        Note: If you are unable to protect a directory, you may have to contact your system administrator to have ".htaccess" based protection enabled on your site. It is almost always enabled but in rare cases the option may have been turned off.

        + +

        Prefs
        +Clicking the “Prefs” link in the Toolbar will display a menu allowing you to customize your FileMan settings.

        + +

        +
        Figure 11: The Preferences menu.

        + +

        Password Directory: This field allows you to specify the path to a directory in which files containing usernames and passwords you specify with the Protect option will be stored.

        + +

        Working Directory: If you wish to select a directory other than your root directory as the default directory that will be displayed when you open FileMan, enter the path to that directory in this field. Do not include a trailing slash.

        + +

        Sort Order: This drop-down menu allows you to select the criteria by which the files and directories you view are sorted.

        + +

        Rows per page: You can configure the maximum number of files and directories that will be displayed per page in the Files menu while using FileMan in this field. Check the “All files” box to display all files and directories on a single page.

        + +

        Pages per screen: At the bottom of the Files menu, a series of page numbers is displayed if the number of files and directories in the directory you are viewing exceeds the number defined in the above option. This field allows you to specify the maximum number of pages that will be displayed at the bottom of the Files menu; additional pages can be accessed by clicking the direction arrows to the left and right of the list of pages.

        + +

        Editor mode: This option allows you to choose whether the HTML editor or the plain text editor will be shown by default when the “New File” link is clicked.

        + +

        The README’s content: When you view a directory containing a file called “Readme”, the first ten lines of that file will automatically be displayed in the Files Menu. This option allows you to choose whether those lines will appear at the top or bottom of the Files Menu.

        + +

        Do you want to show hidden files?: Choose whether or not hidden files will be displayed while using FileMan.

        + +

        Scheme: You can choose from a series of pre-configured colour schemes in the drop-down menu. A sample screen will be displayed.

        + +

        Font: You can define the default font (in HTML format) that will be used in FileMan in this field.

        + +

        Click the “Save” button to confirm any changes you make to FileMan’s preferences, or click the “Cancel” button.

        + +

        Password
        +Clicking the "Password" link displays a form allowing you to change the password used to login to FileMan. + +

        +
        Figure 12: The Password menu.

        + +

        -Enter your "Old Password" and the "New Password" in the fields provided and click the "Change" button. + +

        Log Off
        +Clicking the "Log off" link will log you out of FileMan and return you to the login menu. If you leave FileMan open for three hours without performing any actions, you will be logged out automatically. + +

        The Files Menu



        +The Files Menu displays the files and directories in the directory you are viewing and provides detailed information about each of them through a series of columns.

        + +

        +
        Figure 13: A sample Files Menu.

        + +

        The checkboxes at the left of the Files Menu allows you to select files or directories for the commands found in the Commands Bar. Clicking the checkbox at the top of the menu automatically selects all displayed files and directories.

        + +

        View
        +The icons listed in the view column indicated whether an item is a file or a directory. Clicking the icon beside a desired file or directory will open it. Clicking the “View” heading will sort the files and directories by type.

        + +

        Name
        +The names of all directories and files are displayed in this column. Clicking the name of a desired file or directory will open it. Clicking the “Name” heading will sort the files and directories by name in ascending order. Clicking the “Name” heading a second time will sort them in descending order.

        + +

        Size
        +The sizes of each file are listed in this column. Clicking the “Size” heading will sort the files by size in ascending order. Clicking the “Size” heading a second time will sort them in descending order.

        + +

        File Type
        +The file type of each file (directories are called “file folder”s) is listed in this column. Clicking the “File Type” heading will sort the files and directories by file type in ascending alphabetical order. Clicking the “File Type” heading a second time will sort them in descending alphabetical order.

        + +

        Modified
        +The date that each file or directory was last modified is listed in this column. Clicking the “Modified” heading will sort the files and directories by modification date in ascending order. Clicking the “Modified” heading a second time will sort them in descending alphabetical order.

        + +

        Owner
        +The username of the owner of each file and directory is listed in this column. Clicking the “Owner” heading will sort the files and directories by owner in ascending alphabetical order. Clicking the “Owner” heading a second time will sort them in descending alphabetical order.

        + +

        Permissions
        +The permission settings of each file and directory are listed in this column. Clicking the “Permissions” heading will sort the files and directories by permission settings in ascending alphabetical order. Clicking the “Permissions” heading a second time will sort them in descending alphabetical order. Clicking on the permission settings of a specific file or directory will display a form allowing you to modify the file or directory’s permission settings by checking individual permissions or by entering the numeric code for the desired permissions. If you need more information, a tutorial explaining how to configure permissions is available here.

        + +

        Note: This option will not work if FileMan is running on a Windows server.

        + +

        +
        Figure 14: A sample permission settings menu.

        + +

        The Command Bar



        +The Command Bar allows you to perform commands and actions upon files and directories that you have selected in the Files menu.

        + +

        +
        Figure 15: A sample Command Bar.

        + +

        To the right of the list of commands, a line of text indicates the number of files or directories selected, and a summary of the cumulative size of the selected items.

        + +

        Edit
        +After selecting a single file, clicking the “Edit” link will open the file, allowing you to edit it just as if you’d clicked on its name in the Files menu.

        + +

        Download
        +After selecting one or more files or directories, clicking the “Download” link displays a series of options that allow you to download the items in various file and compression formats.

        + +

        +
        Figure 16: The download menu.

        + +

        -Choose the format of the item(s) you are downloading in the “Options” drop-down menu. Choose between Ascii, Binary and Auto. Ascii format should be used for files that use plain text with no formatting, binary should be used for all other types of files. The auto option will automatically determine which format to use; you will usually not need to specify either Ascii or binary.

        + +

        -If you wish to download the item(s) in a compressed format, select the desired compression format (which should be indicated by the file extensions) from the “Compressed type” drop-down menu. Choose from None, .tar, .tar.gz and .zip. + +

        Note: if you are downloading multiple items, you will have to select a compression type.

        + +

        Note: If your server does not have extension modules that will handle the various compression types, they will not be available. Contact your system administrator if you need to have them installed.

        + +

        -Click the “Download” button.

        + +

        Copy
        +After selecting one or more files or directories, clicking the “Copy” link displays a menu allowing you to specify a directory in which the selected item(s) will be copied.

        + +

        +
        Figure 17: The copy file menu.

        + +

        -Enter the path to the directory you wish to copy the item(s) to, and click the “Copy” button.

        + +

        Delete
        +After selecting one or more files or directories, clicking the “Delete” link will permanently delete them.

        + +

        Move
        +After selecting one or more files or directories, clicking the “Move” link displays a menu allowing you to specify a directory to which the selected item(s) will be moved.

        + +

        +
        Figure 18: The move file menu.

        + +

        -Enter the path to the directory you wish to move the item(s) to, and click the “Move” button.

        + +

        Chmod
        +After selecting one or more files or directories, clicking the “Chmod” link displays a menu allowing you to specify the permissions for the selected item(s), just as if you’d clicked on the permissions of a file in the Files Menu. If you need more information, a tutorial explaining how to configurie permissions is available here. +

        Rescursive: Change files and directories recursively +

        + +

        +
        Figure 19: The Chmod menu.

        + +

        Note: This option will not work if FileMan is running on a Windows server.

        + +

        Tail
        +After selecting a single file, clicking the “Tail” link displays a menu allowing you to configure a screen that will show the last lines of that file.

        + +

        +
        Figure 20: The Tail menu.

        + +

        -Enter how many of the file’s last lines you wish to view in the “Command” field. If you want the tail screen to automatically refresh while you are viewing it, choose a refresh rate (in seconds) from the drop-down menu. This option can be useful when you wish to view access and error logs as they are being generated.

        + +

        Perl
        +After selecting a single file, clicking the “Perl” link will check the syntax of perl files to that the syntax is correct.

        + +

        +
        Figure 21: The Perl menu.

        + +

        Diff
        +After selecting a single file, clicking the “Diff” link displays a menu allowing you to compare the file’s content with that of another and have the differences between the two displayed. This option will only work for text-based files, such as .txt or .html files. This option is useful when reviewing files that are often updated.

        + +

        +
        Figure 22: The Diff menu.

        + +

        -Enter the path to the desired second file and click the “Diff” button.

        + +

        -The differences between the two files will be displayed in a new screen. Lines that are prefaced by a greater-than sign (>) are lines which appear in the second file but not in the first. Lines that are prefaced by a less-than sign (<) are lines which do not appear in the second file but do appear in the first.

        + +

        Compress
        +After selecting a single file, clicking the “Compress” link displays a menu allowing you to choose a compression format and location to save a compressed copy of the file.

        + +

        +
        Figure 23: The Compress menu.

        + +

        -Choose a compression format from the drop-down menu. Choose from .tar, .tar.gz and .zip.

        + +

        -Enter the path to the location you wish to save the compressed file in the field provided. Click the “Create File” button.

        + +

        Note: If your server does not have extension modules that will handle the various compression types, the "Compression" option will not be displayed. Contact your system administrator if you need to have them installed.

        + +

        Print
        +After selecting one or more files, clicking the “Print” link will open a window displaying a preview of the file’s printed appearance, as well as your regular print window. If you select multiple files to be printed, you will be given the option of printing them separately or as one document.

        +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/home.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/home.html new file mode 100644 index 0000000..b0c71ab --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/home.html @@ -0,0 +1,726 @@ + + + + +Gossamer Threads - File Manager + + + + + + + <body bgcolor="#FFFFFF"> + <p>Fileman requires you to use a frames enabled browser..</p> + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/image_print.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/image_print.html new file mode 100644 index 0000000..a28b246 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/image_print.html @@ -0,0 +1,17 @@ + + + <%if next_url%> + + + + <%endif%> +
        <%font%>Print Next
        +
        + + + + +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/login_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/login_form.html new file mode 100644 index 0000000..2830ba9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/login_form.html @@ -0,0 +1,55 @@ + + +Gossamer Threads - File Manager + + + + +
        + + +
        + + + + +
        + + + + + + + +
        FileMan

        + <%font%><%if msg%><%msg%><%else%>Welcome!! Please enter Username and Password.<%endif%>
        + + + + + +    + + + + + + +
        <%font%>User name:   + +
        <%font%>Password:   + +
        +

        + + +
        +
        +
        +
        +
        +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/.tplinfo b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/.tplinfo new file mode 100644 index 0000000..9028194 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/.tplinfo @@ -0,0 +1,3 @@ +{ + inheritance => '../common' +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/compressed.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/compressed.html new file mode 100644 index 0000000..d48af9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/compressed.html @@ -0,0 +1,33 @@ +
        + +
        +
        + + + + + + Question +
        +
        + + + + + + + + + + <%ifnot mswin%><%endif%> + + +
        NAMESIZETYPEMODIFIEDOwnerPermissions
        +
        + +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/editor.html new file mode 100644 index 0000000..201fd6c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/editor.html @@ -0,0 +1,6 @@ +
        + +
        + +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/env.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/env.html new file mode 100644 index 0000000..1c97156 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/env.html @@ -0,0 +1,5 @@ +
        +

        Enviroment

        +
        +
        <%env%>
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/home.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/home.html new file mode 100644 index 0000000..34b0e27 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/home.html @@ -0,0 +1,13 @@ + + + + <%include include_common_head.html%> + + class="noauth"<%endif%> style="overflow: hidden"> + <%~if noauth or $session.user%> + <%include main.html%> + <%~else%> + <%include login.html%> + <%endif~%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_common_head.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_common_head.html new file mode 100644 index 0000000..ca30f07 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_common_head.html @@ -0,0 +1,50 @@ +Gossamer FileMan - File Manager + + + + + + + + +<%~if noauth or $session.user%> + + + + + + +<%endif~%> + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_footer.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_footer.html new file mode 100644 index 0000000..4ce72cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_footer.html @@ -0,0 +1,5 @@ +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_header.html new file mode 100644 index 0000000..567c934 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_header.html @@ -0,0 +1,18 @@ + +<%~if noauth or $session.user%> + +
        +
        +
        + + + +
        +
        +
        +
        +<%endif~%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_form.html new file mode 100644 index 0000000..2aa364e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_form.html @@ -0,0 +1,105 @@ +
        +
        User Information
        + +
        + <%if user.username%><%user.username%> + + <%else%> + * + <%endif%> +
        +
        +
        + +
        <%ifnot user.username%> *<%endif%>
        +
        +
        + +
        + +
        +
        +
        + +
        *
        +
        +
        + +
        +
        +
        class="hide"<%endif%>> +
        + +
        + KB
        + Enter "0" to not create a limit. +
        +
        + <%ifnot user.username%> +
        + +
        +
        + checked="checked"<%endif%> /> +
        +
        + <%endif%> +
        +
        Define command permissions and access directories
        + +
        + + + + + + + + +
        + <%if user.permission.search%> checked="checked"<%endif%><%elsif cfg.default.permission.search%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.replace%> checked="checked"<%endif%><%elsif cfg.default.permission.replace%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.command%> checked="checked"<%endif%><%elsif cfg.default.permission.command%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.upload%> checked="checked"<%endif%><%elsif cfg.default.permission.upload%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.newfile%> checked="checked"<%endif%><%elsif cfg.default.permission.newfile%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.makedir%> checked="checked"<%endif%><%elsif cfg.default.permission.makedir%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.protect%> checked="checked"<%endif%><%elsif cfg.default.permission.protect%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.preferences%> checked="checked"<%endif%><%elsif cfg.default.permission.preferences%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.edit%> checked="checked"<%endif%><%elsif cfg.default.permission.edit%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.download%> checked="checked"<%endif%><%elsif cfg.default.permission.download%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.symlink%> checked="checked"<%endif%><%elsif cfg.default.permission.symlink%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.copy%> checked="checked"<%endif%><%elsif cfg.default.permission.copy%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.move%> checked="checked"<%endif%><%elsif cfg.default.permission.move%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.rename%> checked="checked"<%endif%><%elsif cfg.default.permission.rename%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.delete%> checked="checked"<%endif%><%elsif cfg.default.permission.delete%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.compress%> checked="checked"<%endif%><%elsif cfg.default.permission.compress%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.chmod%> checked="checked"<%endif%><%elsif cfg.default.permission.chmod%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.tail%> checked="checked"<%endif%><%elsif cfg.default.permission.tail%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.perl%> checked="checked"<%endif%><%elsif cfg.default.permission.perl%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.diff%> checked="checked"<%endif%><%elsif cfg.default.permission.diff%> checked="checked"<%endif%> class="checkbox" />
        +
        +
        +
        +
        + +
        +
        + +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_permission.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_permission.html new file mode 100644 index 0000000..67926f0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/include_user_permission.html @@ -0,0 +1,54 @@ +
        +
        Change <%if change_permission eq 'access'%>access directories<%else%>command permissions<%endif%> for following users (The changes will not apply for admin users).
        + +
        <%loop users_loop%><%name%><%ifnot last%>, <%endif%><%endloop%>
        +
        +<%if change_permission ne 'access'%> +
        + +
        + + + + + + + + +
        + checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.replace%> checked="checked"<%endif%><%elsif cfg.default.permission.replace%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.command%> checked="checked"<%endif%><%elsif cfg.default.permission.command%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.upload%> checked="checked"<%endif%><%elsif cfg.default.permission.upload%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.newfile%> checked="checked"<%endif%><%elsif cfg.default.permission.newfile%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.makedir%> checked="checked"<%endif%><%elsif cfg.default.permission.makedir%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.protect%> checked="checked"<%endif%><%elsif cfg.default.permission.protect%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.preferences%> checked="checked"<%endif%><%elsif cfg.default.permission.preferences%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.edit%> checked="checked"<%endif%><%elsif cfg.default.permission.edit%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.download%> checked="checked"<%endif%><%elsif cfg.default.permission.download%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.symlink%> checked="checked"<%endif%><%elsif cfg.default.permission.symlink%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.copy%> checked="checked"<%endif%><%elsif cfg.default.permission.copy%> checked="checked"<%endif%> class="checkbox" /> +
        + <%if user.permission.move%> checked="checked"<%endif%><%elsif cfg.default.permission.move%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.rename%> checked="checked"<%endif%><%elsif cfg.default.permission.rename%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.delete%> checked="checked"<%endif%><%elsif cfg.default.permission.delete%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.compress%> checked="checked"<%endif%><%elsif cfg.default.permission.compress%> checked="checked"<%endif%> class="checkbox" />
        +
        + <%if user.permission.chmod%> checked="checked"<%endif%><%elsif cfg.default.permission.chmod%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.tail%> checked="checked"<%endif%><%elsif cfg.default.permission.tail%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.perl%> checked="checked"<%endif%><%elsif cfg.default.permission.perl%> checked="checked"<%endif%> class="checkbox" />
        + <%if user.permission.diff%> checked="checked"<%endif%><%elsif cfg.default.permission.diff%> checked="checked"<%endif%> class="checkbox" />
        +
        +
        +
        +<%else%> +
        + +
        +
        + +
        +
        +<%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/language.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/language.txt new file mode 100644 index 0000000..9553999 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/language.txt @@ -0,0 +1,96 @@ +# This file is the system default language.txt for for +# the 'gossamer' template set. +# Revision: $Id: language.txt,v 1.13 2008/11/19 23:06:37 bao Exp $ + +my $dump = { + 'ERR_NOUPLOAD' => 'Choose a file to upload.', + 'ERR_INVALID_INPUT' => 'Name cannot contain special characters.', + 'ERR_NOT_FOUND' => '%s does not exist.', + 'ERR_CANNOT_OPEN' => 'Cannot open the %s: %s', + 'ERR_SEARCH_COND' => 'Enter your search condition.', + 'ERR_INVALID_COMMAND' => 'Invalid command: %s', + 'ERR_COMMAND' => 'Enter a command.', + 'ERR_CANNOT_OPEN_MULT' => 'Cannot open multiple files.', + 'ERR_NOAUTH' => 'Your session has expired. Please login again.', + 'ERR_NOT_FILE' => '%s is not a file.', + 'ERR_NOT_FOLDER' => '%s is not a directory', + 'ERR_NOT_WRITABLE' => '%s is not writable.', + 'ERR_NOT_READABLE' => '%s is not readable.', + 'ERR_NOSPACE' => 'There is not enough space on your FileMan account to perform this action.', + 'ERR_EXISTING' => '%s already exists.', + 'ERR_MAKEDIR' => 'Cannot create directory %s: %s', + 'ERR_NOSELECTED' => 'No file was selected.', + 'ERR_CHMOD_INPUT' => 'Enter permission.', + 'ERR_INVALID_PERM' => 'Invalid permissions.', + 'ERR_UID_INVALID' => 'Username cannot contain colon: %s', + 'ERR_UID_EXISTING' => '%s already exists.', + 'ERR_REQUIRED' => '%s is required.', + 'ERR_FILENAME_EXISTING' => 'Filename already exists.', + 'ERR_MAIL_SERVER' => 'You must set either SMTP Server or Mail Path.', + 'ERR_INVALID_MAIL' => 'You cannot set both SMTP Server and Mail Path.', + 'ERR_RENAME_INPUT' => 'A new name is required.', + 'ERR_CANNOT_RENAME' => 'The target path must be the same as the current working path.', + 'ERR_MULT_SELECTED' => 'Cannot select multiple files for this command.', + 'ERR_SYMLINK_INPUT' => 'Enter the path where you want to create a symlink.', + 'ERR_COMPRESS_INPUT' => 'Enter a file name as well as location for your compressed file.', + 'ERR_GZIP_REQUIRED' => 'Compress::Zlib module is required.', + 'ERR_AZIP_REQUIRED' => 'Archive::Zib module is required.', + 'ERR_NOTTEXT_FILE' => '%s is not a text file.', + 'ERR_FILE_EMPTY' => 'The file %s is empty.', + 'ERR_PERL_SELECTED' => 'No Perl files were selected.', + 'ERR_NOTPERL_FILE' => '%s is not a Perl file.', + 'ERR_DIFF_INPUT' => 'Enter the path to the file with which you want to create a diff file.', + 'ERR_INVALID_LOGIN' => 'Invalid login and password.', + 'ERR_INVALID_USERNAME' => 'Invalid username.', + 'ERR_INVALID_PASSWORD' => 'Invalid password.', + 'ERR_SESSION' => 'Cannot create session.', + 'ERR_INVALID_ACTION' => 'Invalid action: %s', + 'ERR_POST_REQUEST' => 'You cannot perform get requests with that command.', + 'ERR_NO_PERM' => 'You do not have permission to use the %s command.', + 'ERR_NO_ACCESS' => 'You do not have any access directories.', + 'ERR_USER_REQUIRED' => 'Username, password, and e-mail address are required fields.', + 'ERR_PROTECT_REQUIRED' => 'Username and password are required fields', + 'ERR_USERNAME' => 'Invalid username', + 'ERR_EMAIL' => 'Invalid e-mail address', + 'ERR_INVALID_ROOT' => 'Invalid root directory: %s', + 'ERR_MAILING' => 'User was successfully created, but the following error occurred: %s', + 'ERR_USER_NOTFOUND' => 'User does not exist: %s', + 'ERR_EMAIL_NOTFOUND' => 'E-mail address does not exist: %s', + 'ERR_NOUSER_SELECTED' => 'No user was selected.', + 'ERR_PASSWD_INPUT' => 'Enter the old and new password.', + 'ERR_INVALID_OLDPASSWD' => 'Invalid old password.', + 'ERR_PASSWD_NOMATCH' => 'Confirmation password does not match new password.', + 'ERR_RESETPWD_INPUT' => 'Enter your e-mail address below.', + 'ERR_OUT_BOUNCE' => 'Permission denied: cannot access outside your root directory.', + 'ERR_INVALID_PATH' => 'Enter the path where you want to copy the selected file(s) to.', + 'ERR_PRINT' => 'Only text files may be printed.', + + 'MSG_PASSWD_RESET' => 'A new password is being sent to you at %s.', + 'MSG_COPIED' => '%s files were copied to %s.', + 'MSG_MOVED' => '%s files were moved to %s.', + 'MSG_DELETED' => '%s file was deleted.', + 'MSG_MULT_DELETED' => '%s files were deleted.', + 'MSG_SEARCH' => 'Search results: %s file(s)', + 'MSG_REPLACED' => 'Replace results: %s file(s)', + 'MSG_UPLOADED' => '%s was uploaded (%s)', + 'MSG_MULT_UPLOADED' => '%s files uploaded (%s), %s files skipped.', + 'MSG_FILE_SAVED' => '%s was saved.', + 'MSG_MAKEDIR' => 'Directory %s created.', + 'MSG_MULT_CHMODED' => 'Permissions changed on %s files and directories.', + 'MSG_CHMODED' => '%s permissions changed.', + 'MSG_USER_ADDED' => '%s user added.', + 'MSG_USER_DELETED' => '%s use deleted', + 'MSG_MULTUSER_DELETED' => '%s users deleted', + 'MSG_USER_UPDATED' => '%s user updated.', + 'MSG_CHANCES_SAVED' => 'All the changes were saved.', + 'MSG_RENAMED' => '%s was renamed to %s', + 'MSG_LINKED' => '%s link(s) created at %s.', + 'MSG_COMPRESSED' => '%s created!', + 'MSG_UNCOMPRESSED' => '%s of %s files were uncompressed from %s', + 'MSG_LOGOUT' => 'You have logged out successfully.', + 'MSG_PERM_SAVED' => 'Command permissions changed for %s users.', + 'MSG_ACCESS_SAVED' => 'Directory access changed for %s users.', + 'MSG_PASSWD_UPDATED' => 'Your new password was updated.', + 'MSG_LOG_DELETED' => 'Logs were deleted.', + 'MSG_REQUIRED' => 'The "%s" field cannot be left blank.' +}; diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log.html new file mode 100644 index 0000000..6452be2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log.html @@ -0,0 +1,23 @@ +
        +
        + + Question +
        + + + + + + + + + +
        DateUserIP AddressActionsDescription
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log_search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log_search.html new file mode 100644 index 0000000..46c72c7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/log_search.html @@ -0,0 +1,53 @@ + + +

        + + Log Search +

        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/login.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/login.html new file mode 100644 index 0000000..2f57f80 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/login.html @@ -0,0 +1,52 @@ +
        +
        + <%include include_header.html~%> +
        +
        + + +
        +
        +
        class="hide"<%endif%>>
        <%if error%><%error%><%elsif message%><%message%><%endif%>
        +
        +
        +
        +
        +
        +

        Login

        +

        Welcome to Gossamer FileMan. Please enter your username, and password below.

        +
        + +
        +
        +
        + +
        +
        +
        + +
        + +
        +
        + + <%if cfg.fversion eq 'multiple'%><%endif%> +
        + +
        + +
        +
        +
        +
        +
        +
        +
        +
        +
        + + <%include include_footer.html%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/main.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/main.html new file mode 100644 index 0000000..2e91c12 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/main.html @@ -0,0 +1,414 @@ +
        +
        + <%include include_header.html~%> +
        +
        +
        +
        <%hidden_objects%>
        + +
        + <%~if noauth or $session.user.type or $session.user.permission.search%> + + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.replace%> +
        +
        + +
        + + + + + + Question +
        +
        +
        + +
        + + + + + + + + +
        +
        +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.command%> + <%~ifnot mswin%> +
        +
        + + + + +
        +
        + + + + Question +
        +
        + <%endif~%> + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.upload%> +
        +
        + +
        + + + Question + Upload Files +
        +
        +
        + +
        + + +
        +
        +
        + <%endif~%> +
        +
        + +
        + + + Question +
        +
        + <%~if noauth or $session.user.type or $session.user.permission.newfile%> +
        +
        + +
        + + + Question +
        +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.makedir%> +
        +
        Enter directory name below:
        +
        + + + Question +
        +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.protect%> +
        +
        + +
        + + + +
        +
        +
        + +
        + + + + + <%if apache_server%><%endif%> + + Question +
        +
        +
        + <%endif~%> +
        +
        +
        +
        +
        +
        +
        +
        +
        +
        +
        + +
        + <%~if noauth or $session.user.type or $session.user.permission.download%> +
        + + + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.symlink%> + + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.copy%> +
        + + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.move%> +
        + + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.rename%> +
        + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.compress%> +
        + + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.chmod%> + <%~ifnot mswin%> +
        +
        +
        + User: + + + +
        +
        + Group: + + + +
        +
        + Other: + + + +
        +
        + Or
        (in octal notation) +
        +
        + + + + Question +
        +
        +
        + <%endif~%> + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.tail%> +
        + + + + + Question +
        + <%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.diff%> +
        + + + + + Question +
        + <%endif~%> +
        +
        + +
        + + + + + + + + <%~ifnot mswin%><%endif~%> + <%~ifnot mswin%><%endif~%> + + +
        NAMESIZETYPEMODIFIEDOwnerPermissions
        +
        + +
        +
        +
        + + +
        + + + + + + + + +
          + <%~if noauth or $session.user.type or $session.user.permission.search%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.replace%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.command%><%~ifnot mswin%><%endif~%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.upload%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.newfile%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.makedir%><%endif~%> + <%~if noauth or $session.user.type or $session.user.permission.protect%><%endif~%> + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/password.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/password.html new file mode 100644 index 0000000..7dbbf14 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/password.html @@ -0,0 +1,22 @@ +
        +

        Change Password

        + + Question +
        +
        +
        +
        Enter your current and new password in the form below
        + +
        *
        +
        +
        + +
        *
        +
        +
        + +
        + * +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/preferences.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/preferences.html new file mode 100644 index 0000000..3ef736f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/preferences.html @@ -0,0 +1,102 @@ +
        +

        Preferences

        + + Question +
        +
        +
        +
        This field allows you to specify the directory that will be displayed by default when you login.
        + +
        + +
        +
        +
        +
        This field should contain the path to the directory where your .htaccess file (which stores passwords created with the Protect option) is stored.
        + +
        + +
        +
        +
        +
        Specify the order in which your files and directories will be sorted and displayed by choosing a criteria (Name, Size, Type, Modified, Owner, Permissions) and either descending or ascending order. Note that directories will always be displayed above files.
        + +
        + + +
        +
        +
        +
        The number of files and directories that will be displayed per page.
        + +
        + +
        +
        +
        +
        Choose whether or not to display hidden files while viewing directories.
        + +
        + +
        +
        +
        +
        Choose whether the plain Text editor or the HTML editor will be displayed by default when you are creating new files.
        + +
        + +
        +
        +
        +
        Choose whether to use visual effects for various Fileman menus and alerts
        + +
        + +
        +
        +
        +
        Choose whether README files (which are automatically displayed when a directory is being viewed) above, below or not shown the directory structure.
        + +
        + +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.eml new file mode 100644 index 0000000..6e225ba --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.eml @@ -0,0 +1,19 @@ +To: <%user.email%> +Subject: Temporary password +From: <%cfg.email.admin%> + + +Hi <%if user.name%><%user.name%><%else%><%user.username%><%endif%>, + +The following temporary password has been activated for your account. Please +login using the following information: + +Username: <%user.username%> +Password: <%new_passwd%> + +PLEASE READ: This temporary account is only good for a single login. Once you +have logged in, please click on Tools - Password and change your password. + +Should you have any problems, please contact the site administrator at + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.html new file mode 100644 index 0000000..bf89a88 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/reset_password.html @@ -0,0 +1,17 @@ +
        +

        Reset Password

        +

        Please enter your e-mail address to retrieve a new password.

        +
        + +
        +
        + + +
        + +
        + +
        +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/search.html new file mode 100644 index 0000000..bd5ae2f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/search.html @@ -0,0 +1,59 @@ +
        + <%hidden_objects%> +

        + + Advanced Search +

        + +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/setup.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/setup.html new file mode 100644 index 0000000..418372b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/setup.html @@ -0,0 +1,152 @@ +
        +

        Setup

        + + Question +
        +
        +
        +
        Paths and URLs
        + +
        + +
        +
        +
        + +
        + +
        +
        +
        + +
        + +
        +
        + <%if session.user.type%> +
        +
        E-mail Setup
        + +
        + +
        +
        +
        + +
        + +
        +
        +
        + +
        + +
        +
        + <%endif%> +
        +
        Other Options
        + +
        + +
        +
        +
        + +
        + +
        +
        + <%if session.user.type%> +
        + +
        + days +
        +
        + <%endif%> + <%ifnot in.sid%> +
        + +
        + + + +
        +
        + <%endif%> + <%~ifnot mswin%> +
        + +
        + +
        +
        + <%endif~%> +
        + +
        + +
        +
        +
        + <%if session.user.type%>
        Default Values
        <%endif~%> + +
        + +
        +
        + <%if session.user.type%> +
        + +
        + +
        +
        +
        + +
        + + + + + + + + +
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" /> +
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" /> +
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" /> +
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        +
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        + checked="checked"<%endif%> class="checkbox" />
        +
        +
        +
        + <%endif%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user.html new file mode 100644 index 0000000..c6f86c2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user.html @@ -0,0 +1,25 @@ +
        +

        User management

        + Question +
        + + + + + + + + + +
        UsernameTypeDirectory Access
        +
        + +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_form.html new file mode 100644 index 0000000..499b809 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_form.html @@ -0,0 +1,18 @@ +
        +

        + <%~if user.username%>Modify a User + <%elsif change_permission eq 'access'%>Change Accesses + <%elsif change_permission eq 'permission'%>Change Permissions + <%~else%>Create a User<%endif~%> +

        + + + Question +
        +
        + <%~if change_permission%> + <%~include include_user_permission.html%> + <%~else%> + <%~include include_user_form.html%> + <%~endif%> +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_signup.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_signup.eml new file mode 100644 index 0000000..03717b4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/luna/user_signup.eml @@ -0,0 +1,16 @@ +To: <%user.email%> +Subject: Fileman signup information. +From: <%cfg.email.admin%> + + +Hi <%if user.name%><%user.name%><%else%><%user.username%><%endif%>, + +A Fileman account has been signed up for you. Your account information +can be found below: + +<%cfg.cgi_url%> +Username: <%user.username%> +Password: <%user.password%> + +If you have any questions, please contact Administrator at <%cfg.email.admin%>. + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/main.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/main.html new file mode 100644 index 0000000..8e90798 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/main.html @@ -0,0 +1,258 @@ + + + +
        +<%if readme%><%if position eq 'Y'%>

        <%font%><%readme%><%endif%><%endif%> + + <%if search%> + <%if cmd_do eq "cmd_search" or cmd_do eq "cmd_replace"%> + + <%endif%> + <%endif%> + + + +<%if speed_bar%> + + + +<%endif%> +
        <%font%> + +       <%status%>
        + + + + + + + + + + + + <%loop results%> + class="background"<%else%>class="bg_main"<%endif%>> + + + + + + + + + + <%endloop%> +
        + <%if num_objects > 1%><%else%> <%endif%> + <%font%><%sview%><%font%><%sname%><%font%><%ssize%><%font%><%stype%><%font%><%sdate%><%font%><%suser%><%font%><%sperm%>
        + <%if type%> + <%if disabled%> + + <%else%> + + <%endif%> + <%else%> +   + + <%endif%> + + + <%if disabled%> + <%icon%> + <%else%> + <%if isdir%> + + <%else%> + + <%endif%><%icon%> + <%endif%> + <%font%> + <%if disabled%> + <%name%> + <%else%> + <%if isdir%> + <%name%> + <%else%> + <%if show_all%> + <%name%> + <%else%> + <%ifnot cmd_edit%> + <%name%> + <%else%> + <%name%> + <%endif%> + <%endif%> + <%endif%> + <%endif%> + <%font%><%if size%><%size%><%else%> <%endif%><%font%><%if type%><%type%><%else%> <%endif%><%font%><%date%><%font%><%user%><%font%> + <%if show_all%> + <%if type%><%perm%><%endif%> + <%else%> + <%ifnot cmd_chmod%> + <%perm%> + <%else%> + <%if type%><%perm%><%endif%> + <%endif%> + <%endif%> +   + +
        +
        <%font%>Page:  <%speed_bar%>
        +<%ifnot position%> +<%set position="N"%> +<%endif%> +<%if readme%><%if position eq 'N'%>

        <%font%><%readme%><%endif%><%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +<%if re_scheme%> + +<%endif%> +

        +<%if allowed_space and usage > 0%> + + + + + <%if usage > 0 and usage < 100%> + + + + <%endif%> +
        <%font%>You are using <%usage%>% of your <%allowed_space%> limit.
        + + +
        + + + + + +
        +
        +
        +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/multi_upload.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/multi_upload.html new file mode 100644 index 0000000..260fd3f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/multi_upload.html @@ -0,0 +1,176 @@ + + +FileMan + + + + + +
        + + + + +
        + + + + +
        + + + + + +
         Multiple uploading 
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        <%font%> 1.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 2.<%font%> + + Ascii + Binary + Auto  +
        <%font%> 3.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 4.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 5.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 6.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 7.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 8.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 9.<%font%> + + Ascii + Binary + Auto   +
        <%font%> 10. + <%font%> + Ascii + Binary + Auto   +

        <%font%> + File name as: +    + <%font%>Overwrite +

        + +

        +
        +
        +
        + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/preferences.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/preferences.html new file mode 100644 index 0000000..8e34eff --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/preferences.html @@ -0,0 +1,301 @@ + + +FileMan + + + + + +
        + +
        + + + + +
        + + + + + +
         Preferences 

        + <%if msg%> + + +
        <%font%><%msg%>
        + <%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        <%font%>Default Paths
          + + + + + + + + +
        <%font%>Password Directory <%ifnot passwd_dir_level%>Root:/<%endif%><%font%> +
        (No trailing slash) +
        <%font%>Working Directory<%font%> + +
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        <%font%>Display
          + + + + + + + + + + + + + +
        <%font%>Sort Order + +
        <%font%>Rows per page<%font%> + +    + checked<%endif%> value=on name=showall onclick="show_default()" > All files +
        <%font%>Pages per screen + +
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        <%font%>File Display
          + + <%if ie_version >= 5.5 or mozilla_version >= 1.4%> + + + + + <%endif%> + + + + + + + +
        <%font%>Editor mode + +
        <%font%>The README's content + +
        <%font%> + checked<%endif%>> + Show hidden files? +
        +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        <%font%>Color & Font
          + + + + + +
        + + + + + + + + <%ifnot multi%> + + + + <%endif%> +
        <%font%>Scheme:
        + + +
        <%font%>Font:
        + + <%font%>

        Refresh the browser if it's Netscape Navigator
        +
        + <%font%>Environment +
        +
        + +
        +
        +
        + + + + +
        + +

        +
        + +
        +
        + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%>
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/progress_bar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/progress_bar.html new file mode 100644 index 0000000..048cbc8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/progress_bar.html @@ -0,0 +1,65 @@ +<%if confirm%> + +
        + +
        + + + +
        + + + + + +
         Copy confirm 
        + + + + + + +
        <%font%>
        Overwrite: <%to%>
        <%font%>
        with: <%from%>

        + + + +

        +
        +
        +
        +<%loop results%> + +<%endloop%> + + + + + + + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        +<%else%> + +<%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_confirm.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_confirm.html new file mode 100644 index 0000000..ab8a869 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_confirm.html @@ -0,0 +1,52 @@ + +
        + +
        + + + +
        + + + + + +
         Tar confirm 
        + + + + +
        <%font%>
        <%file%> file already exists, do you want to overwrite it?

        + +

        +
        +
        +
        +<%loop results%> + +<%endloop%> + + + + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_information.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_information.html new file mode 100644 index 0000000..1941afb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/tar_information.html @@ -0,0 +1,93 @@ + + + +
        + + + + + + +
        + +
        + + + + + + + + + + + <%loop results%> + class="background"<%else%>class="bg_main"<%endif%>> + + + + + + + + + <%endloop%> +
         NameSizeDateOwnerPermissions
        + + + <%font%><%if type eq 5%><%else%><%icon%><%endif%><%font%><%name%> <%font%><%size%> <%font%><%date%> <%font%><%uid%> <%font%><%chmod%> 
        +
        <%font%>User to extract: <%user%>
        +<%if speed_bar%><%font%>Pages: <%speed_bar%><%endif%> + + + + + + + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/top_frame.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/top_frame.html new file mode 100644 index 0000000..2f1f255 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/top_frame.html @@ -0,0 +1,24 @@ + + + + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/user_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/user_form.html new file mode 100644 index 0000000..7051b16 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/user_form.html @@ -0,0 +1,84 @@ + + +FileMan + + + +
        + + + + +
        + <%if msg%> + + +
        <%font%><%msg%>
        + <%endif%> + + + + +
        + + + + + +
         Change password

        + + + + + + + +
        + + + + + + + + + +
        <%font%>Old Password: + + +
        <%font%>New Password: + +
        +

        + + +

        +
        +
        +
        + + + + + + + + + + + + + + + + +<%ifnot user_sessions%> + + +<%endif%> +<%if root_selected%> + +<%endif%> +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/view_image.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/view_image.html new file mode 100644 index 0000000..eb034f5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/fileman/view_image.html @@ -0,0 +1,23 @@ + + + + +
        + +
        +
        + + + + + + + +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help.html new file mode 100644 index 0000000..7a5d333 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help.html @@ -0,0 +1,19 @@ + + + +Gossamer Links - Help + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/AutoLoader.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/AutoLoader.html new file mode 100644 index 0000000..6419717 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/AutoLoader.html @@ -0,0 +1,470 @@ + + + + +GT::AutoLoader - load subroutines on demand + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::AutoLoader - load subroutines on demand

        +

        +

        +
        +

        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
        +

        +

        +
        +

        DESCRIPTION

        +

        The 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, 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 GT::AutoLoader, in its standard behaviour, simply put: +use GT::AutoLoader; in your module. When you use GT::AutoLoader, two things +will happen. First, an 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/;

        +

        +

        +
        +

        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");
        +
        +
        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');
        +
        + +
        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 use GT::AutoLoader like this:

        +
        +
        +
        +    use GT::AutoLoader(LOG => sub {
        +        print "Compiled $_[1] in package $_[0]\n"
        +    });
        +
        + +
        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 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.

        +
        + +
        +

        +

        +
        +

        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!

        +

        +

        +
        +

        REQUIREMENTS

        +

        None.

        +

        +

        +
        +

        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 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.

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Base manpage

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Base.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Base.html new file mode 100644 index 0000000..4cb5c19 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Base.html @@ -0,0 +1,429 @@ + + + + +GT::Base - Common base module to be inherited by all classes. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Base - Common base module to be inherited by all classes.

        +

        +

        +
        +

        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",
        +    };
        +

        +

        +
        +

        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:

        +

        +

        +

        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.

        +

        +

        +

        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();
        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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 &GT::Base::AUTOLOAD;
        +    }
        +

        which will pass all arguments as well.

        +

        +

        +

        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.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Base.pm,v 1.135 2007/11/10 06:46:21 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/CGI.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/CGI.html new file mode 100644 index 0000000..41e9427 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/CGI.html @@ -0,0 +1,522 @@ + + + + +GT::CGI - a lightweight replacement for CGI.pm + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::CGI - a lightweight replacement for CGI.pm

        +

        +

        +
        +

        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/;
        +

        +

        +
        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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:

        +
        +
        -force => 1 + +
        +

        Force printing of header even if it has already been displayed.

        +
        + +
        -type => 'text/plain' + +
        +

        Set the type of the header to something other then text/html.

        +
        + +
        -charset => 'iso-8859-1' + +
        +

        Set the character set that is sent to the browser. This is only applicable to +text types. If this option is not passed in, then no character set is sent.

        +
        + +
        -cookie => $cookie + +
        +

        Display any cookies. You can pass in a single GT::CGI::Cookie object, or an +array of them.

        +
        + +
        -nph => 1 + +
        +

        Display full headers for nph scripts.

        +
        + +
        -no-cache => 1 + +
        +

        Send the appropriate headers to prevent the browser from caching the resulting +page.

        +
        + +
        -url => $url + +
        +

        Redirect the user to the supplied url. By default, it performs a temporary +(302) redirect. Use the -permanent option to perform a permanent (301) +redirect.

        +
        + +
        -permanent => 1 + +
        +

        Used with the -url option to perform a permanent (301) redirect.

        +
        + +
        +

        If called with a single argument, sets the Content-Type.

        +

        +

        +

        redirect - Redirecting to new URL.

        +

        Returns a Location: header to redirect a user.

        +

        +

        +

        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, +-secure if the cookie is only valid for secure sites, and -httponly to prevent +client side scripts from reading the cookie (for browsers that support it).

        +

        You would then set the cookie by passing it to the header function:

        +
        +    print $in->header ( -cookie => $c );
        +

        +

        +

        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:

        +
        +
        absolute => 1 + +
        +

        Return the full URL: http://domain/path/to/script.cgi

        +
        + +
        relative => 1 + +
        +

        Return only the script name: script.cgi

        +
        + +
        query_string => 1 + +
        +

        Return the query string as well: script.cgi?a=b

        +
        + +
        path_info => 1 + +
        +

        Returns the path info as well: script.cgi/foobar

        +
        + +
        remove_empty => 0 + +
        +

        Removes empty query= from the query string.

        +
        + +
        +

        +

        +

        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.

        +

        +

        +

        escape - URL escape a string.

        +

        Returns the passed in value URL escaped. Can be called as class method or +object method.

        +

        +

        +

        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.

        +

        +

        +

        html_escape - HTML escape a string

        +

        Returns the passed in value HTML escaped. Translates &, <, > and `` to their +html equivalants.

        +

        +

        +

        html_unescape - HTML unescapes a string

        +

        Returns the passed in value HTML unescaped.

        +

        +

        +

        post_data - Return POSTed data.

        +

        If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed. You can +retrieve this data using this method.

        +

        +

        +

        upload_hook - Callback for file uploads

        +

        Takes a code reference, and for every file upload, runs the code reference +and passes it the filename, a reference to the data, and the total bytes +read.

        +

        Must be called before any other function, or as a parameter to new.

        +

        +

        +
        +

        DEPENDENCIES

        +

        Note: GT::CGI depends on the GT::Base manpage and the GT::AutoLoader manpage, and if you are +performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and the GT::TempFile manpage. +The ability to set cookies requires GT::CGI::Cookie.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: CGI.pm,v 1.159 2009/04/07 22:34:18 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Cache.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Cache.html new file mode 100644 index 0000000..0ef7094 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Cache.html @@ -0,0 +1,345 @@ + + + + +GT::Cache - Tied hash which caches output of functions. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Cache - Tied hash which caches output of functions.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Cache;
        +    my %cache;
        +    tie %cache, 'GT::Cache', $size, \&function;
        +

        +

        +
        +

        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.

        +

        +

        +
        +

        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.

        +

        +

        +
        +

        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.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Config.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Config.html new file mode 100644 index 0000000..18f6d17 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Config.html @@ -0,0 +1,604 @@ + + + + +GT::Config - Dumped-hash configuration handler + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Config - Dumped-hash configuration handler

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Config;
        +    my $Config = GT::Config->load($config_file);
        +    ...
        +    print $Config->{variable};
        +    ...
        +    $Config->{othervar} = "something";
        +    ...
        +    $Config->save;
        +

        +

        +
        +

        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 the GT::Template manpage) and mtime-based +caching.

        +

        +

        +
        +

        METHODS

        +

        +

        +

        load

        +

        There is no 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:

        +
        +
        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.

        +
        + +
        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 +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.

        +
        + +
        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 cache => 0 to disable cached loading. +Note that new objects are always stored in the cache, allowing you to specify +cache => 0 to force a reload of a cached file.

        +
        + +
        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 create_ok => 1 if the config file doesn't +necessarily have to exist (i.e. when creating a new config file).

        +
        + +
        empty + +
        +

        The empty option is used to create a new, blank config file - it can be +thought of as a forced version of the create_ok option. It won't read +any files during loading (and as such completely ignores the inheritance +and 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.

        +
        + +
        chmod + +
        +

        The chmod option is used to specify the mode of the saved file. It must be +passed in octal form, such as 0644 (but not in string form, such as +"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.

        +
        + +
        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 - $CFG->{foo}->{bar} will not fatal if foo is a +hash ref, but bar is not set in that hash reference. $CFG->{foo} +(and $CFG->{foo}->{bar}) will fatal if the key foo does not exist +in the config data.

        +
        + +
        debug + +
        +

        If provided, debugging information will be printed. This will also cause a +warning to occur if fatal is disabled and load fails.

        +
        +
        +

        Defaults to disabled. Should not be used in production code, except when +debugging.

        +
        + +
        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 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.

        +
        + +
        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 [localtime], which will be +replaced with the return value of scalar localtime() when saving, which is +generally a value such as: Sun Jan 25 15:12:26 2004.

        +
        + +
        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.

        +
        + +
        compile_subs + +
        +

        If provided, any data starting with 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 sub {) when saving.

        +
        +
        +

        NOTE: The argument to compile_subs must be a valid perl package; the code +reference will be compiled in that package. For example, +compile_subs => '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.

        +
        + +
        sort_order + +
        +

        If provided, the option will be passed through as the 'order' option of +GT::Dumper for hash key ordering. See the GT::Dumper manpage. GT::Config always sorts +hash keys - this can be used when the default alphanumeric sort is not +sufficient.

        +
        + +
        +

        +

        +

        save

        +

        To save a config file, simply call $object->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();
        +

        NOTE: 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.

        +

        +

        +

        cache_hit

        +

        Returns whether or not the current object was loaded from cache (1) or loaded +from disk (undef).

        +

        +

        +

        inheritance

        +

        Returns the inheritance status (1 or 0) of the object.

        +

        +

        +

        create_ok

        +

        Returns the status (1 or 0) of the ``create_ok'' flag.

        +

        +

        +

        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.

        +

        +

        +

        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 load() instead.

        +

        +

        +

        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.

        +

        +

        +

        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 [localtime], which will be +replaced with the return value of scalar localtime() when saving.

        +

        +

        +

        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 the GT::Dumper manpage. +GT::Config always sorts hash keys - this can be used when the default +alphanumeric sort is not sufficient.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Template::Inheritance manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        $Id: Config.pm,v 1.47 2007/02/24 00:59:17 sbeck Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Date.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Date.html new file mode 100644 index 0000000..44f8105 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Date.html @@ -0,0 +1,491 @@ + + + + +GT::Date - Common date parsing and manipulation routines + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Date - Common date parsing and manipulation routines

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Date qw/:all/;
        +    my $date = date_get();
        +    my $next_week = date_add($date, 7);
        +    my $is_bigger = date_is_greater($date, $next_week);
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Date provides several functions useful in parsing dates, and +doing date manipulation. Under the hood, it uses Time::Local +code to transform a date into seconds for comparison and +mathematical operations. It also uses the GT::Cache manpage to store +most of the complex work.

        +

        No functions are exported by default. You can either specify +the functions you need in use, or use the tags ':all' or +':timelocal'. All will give you all functions, and timelocal +will give you functions found in Time::Local.

        +

        GT::Date uses a package global $DATE_FMT which specifies +the format that dates should be returned in. You can change this using +the date_set_format() function.

        +

        +

        +

        date_is_valid

        +

        Returns 1 if the argument passed in is a valid date. It must first +be in the current date format, and then be a valid date.

        +

        +

        +

        date_is_greater

        +

        Returns 1 if argument 1 is greater then argument 2, otherwise 0.

        +

        +

        +

        date_is_smaller

        +

        Returns 1 if argument 1 is smaller then argument 2, otherwise 0.

        +

        +

        +

        date_get date_get_gm

        +

        Called with no arguments, returns the current date based on system +time. You can specify the date you want by passing in the seconds +since epoch (output of time()).

        +

        +

        +

        date_comp

        +

        Equivalent to arg1 <=> arg2.

        +

        +

        +

        date_diff

        +

        Returns number of days difference between arg1 - arg2.

        +

        +

        +

        date_add date_add_gm

        +

        Returns date derived from arg1 + arg2, where the second argument +can be either a date or number of days.

        +

        +

        +

        date_sub date_sub_gm

        +

        Returns date derived from arg1 - arg2, where the second argument +can be either a date or number of days.

        +

        +

        +

        timegm

        +

        Takes the returned array from gmtime() and returns a unix time +stamp.

        +

        +

        +

        timelocal

        +

        Takes the array returned by localtime() and returns a unix time +stamp.

        +

        +

        +

        parse_format

        +

        Takes a string and a date format and returns an array +ref of the first 7 arguments returned by localtime().

        +

        +

        +

        format_date

        +

        Takes a localtime array, and a format string and returns a string +of the parsed format.

        +

        +

        +

        Setting date format

        +

        You can use date_set_format to change the format. You pass in a +format string. It is made up of:

        +
        +    %yyyy%      four digit year as in 1999
        +    %yy%        two digit year as in 99
        +    %y%         two digit year without leading 0
        +    %mmmm%      long month name as in January
        +    %mmm%       short month name as in Jan
        +    %mm%        numerical month name as in 01
        +    %m%         numerical month name without leading 0 as in 1
        +    %dddd%      long day name as in Sunday
        +    %ddd%       short day name as in Sun
        +    %dd%        numerical date
        +    %d%         numerical date without leading 0
        +    %HH%        two digit hour, 24 hour time
        +    %H%         one or two digit hour, 24 hour time
        +    %hh%        two digit hour, 12 hour time. 0 becomes 12.
        +    %h%         one or two digit hour, 12 hour time. 0 becomes 12.
        +    %MM%        two digit minute
        +    %M%         one or two digit minute (when would someone ever WANT this?)
        +    %ss%        two digit second
        +    %s%         one ot two digit second (when would someone ever WANT this?)
        +    %tt%        AM or PM (use with 12 hour time)
        +    %o%         + or - GMT offset
        +

        Common formats include:

        +
        +    %yyyy%-%mm%-%dd%            1999-12-25
        +    %dd%-%mmm%-%yyyy%           12-Dec-1999
        +    %ddd% %mmm% %dd% %yyyy%     Sat Dec 12 1999
        +    %ddd% %mmm% %dd% %yyyy%     Sat Dec 12 1999
        +

        or RFC822 mime mail format:

        +
        +     %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%   Sat, 12, Dec 1999 21:32:02 -0800
        +

        or MySQL format:

        +
        +    %yyyy%-%mm%-%dd% %HH%:%MM%:%ss%  1999-03-25 21:32:02
        +

        The language used for month names and day names can be changed with +date_set_month(), date_set_days(), date_set_days_short() and +date_set_month_short().

        +

        +

        +

        Transforming between date formats.

        +

        You can transform a date from one format to another with:

        +
        +    date_transform ($date, $orig_fmt, $new_fmt);
        +

        where $orig_fmt and $new_fmt are date format strings described above.

        +

        +

        +

        Getting the GM offset.

        +

        You can get the number of seconds between the system time and GM time +using:

        +
        +    my $time = date_gmt_offset();
        +

        So if you are in Pacific time, it would return 25200 seconds (-0700 time zone).

        +

        +

        +
        +

        EXAMPLES

        +

        Get todays date, the default format unless specified is yyyy-mm-dd.

        +
        +    print date_get();                 2000-12-31
        +

        Get todays date in a different format:

        +
        +    date_set_format('%ddd% %mmm% %dd% %yyyy%');
        +    print date_get();                               Sat Dec 31 2000
        +

        Get the date from 1 week ago.

        +
        +    # Long way
        +    my $date1 = date_get();
        +    my $date2 = date_sub($date1, 7);
        +
        +        or
        +
        +    # Can pass in unix timestamp of date we want.
        +    my $date = date_get (time - (7 * 86400));
        +

        Compare two dates.

        +
        +    my $halloween = '2000-10-31';
        +    my $christmas = '2000-12-25';
        +    if (date_is_smaller($halloween, $christmas)) {
        +        print "Halloween comes before christmas!";
        +    }
        +    if (date_is_greater($christmas, $halloween)) {
        +        print "Yup, christmas comes after halloween.";
        +    }
        +    my @dates = ($halloween, $christmas);
        +    print "Dates in order: ", sort date_comp @dates;
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Date.pm,v 1.81 2007/07/24 17:40:22 aki Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Delay.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Delay.html new file mode 100644 index 0000000..53c9687 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Delay.html @@ -0,0 +1,387 @@ + + + + +GT::Delay - Generic delayed module loading + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Delay - Generic delayed module loading

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Delay;
        +
        +    my $obj = GT::Delay('GT::Foo', 'HASH', foo => "bar", bar => 12);
        +
        +    ... # time passes without using $obj
        +
        +    $obj->method();
        +

        +

        +
        +

        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.

        +

        +

        +
        +

        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).

        +

        +

        +

        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.

        +

        +

        +
        +

        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: +$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, +$obj->{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, delete $self->{foo}->{bar} - though 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.

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Dumper.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Dumper.html new file mode 100644 index 0000000..f0f1b54 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Dumper.html @@ -0,0 +1,469 @@ + + + + +GT::Dumper - Convert Perl data structures into a string. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Dumper - Convert Perl data structures into a string.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Dumper;
        +    print Dumper($complex_var);
        +    print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var);
        +

        +

        +
        +

        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 = .

        +

        +

        +
        +

        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',
        +        ],
        +    };
        +

        +

        +
        +

        METHODS/FUNCTIONS

        +

        +

        +

        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 dump method.

        +

        +

        +

        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 data option is required.

        +
          +
        • data + +

          The data option takes a data structure to dump. It is required.

          +
        • +
        • var + +

          By default, a dump is output as an assignment to $VAR. For example, dumping +the string foo would return: $VAR = 'foo'. You can change and even omit +the assignment using the var option. To specify a different variable, you +simply specify it as the value here. To have 'foo' dump as just 'foo' +instead of $VAR = 'foo', specify var as an empty string, or undef.

          +
        • +
        • 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 tab option.

          +
        • +
        • sort + +

          The 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 order option for +specifying your own sort order.

          +
        • +
        • order + +

          When sorting, it is sometimes desirable to use a custom sort order rather than +the default case-sensitive alphabetical sort. The 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.

          +
        • +
        • 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:

          +
            +
          • assignment + +

            If using a var (ie. $VAR = DATA), the spaces around the = will be stripped. +The output will look like: $VAR=DATA

            +
          • +
          • hash keys + +

            Instead of placing the 4 characters ' => ' between hash keys and values, a +single ',' will be used.

            +
          • +
          • tabs + +

            Tabs will not be used.

            +
          • +
          • newlines + +

            Normally, a newline character is added after each dumped element. Compress +turns this off.

            +
          • +
          +
        • 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 var option is +ignored - it is treated as if a blank 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.

          +
        • +
        +

        +

        +

        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 structure option.

        +

        +

        +
        +

        SEE ALSO

        +

        the Data::Dumper manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Dumper.pm,v 1.39 2007/02/10 15:59:02 sbeck Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Diff.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Diff.html new file mode 100644 index 0000000..788371d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Diff.html @@ -0,0 +1,669 @@ + + + + +Algorithm::Diff - Compute `intelligent' differences between two files / lists + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        Algorithm::Diff - Compute `intelligent' differences between two files / lists

        +

        +

        +
        +

        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,
        +                     } );
        +

        +

        +
        +

        INTRODUCTION

        +

        (by Mark-Jason Dominus)

        +

        I once read an article written by the authors of 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 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 S to be as long as possible. In this case +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 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 a and 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 a b c z. But actually, the LCS +is a x b y c z:

        +
        +              a x b y c z p d q
        +        a b c a x b y c z
        +

        +

        +
        +

        USAGE

        +

        This module provides three exportable functions, which we'll deal with in +ascending order of difficulty: LCS, +diff, sdiff, traverse_sequences, and traverse_balanced.

        +

        +

        +

        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 );
        +

        LCS may be passed an optional third parameter; this is a CODE +reference to a key generation function. See 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.

        +

        +

        +

        diff

        +
        +  @diffs     = diff( \@seq1, \@seq2 );
        +  $diffs_ref = diff( \@seq1, \@seq2 );
        +

        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 hunks; each hunk +represents a contiguous section of items which should be added, +deleted, or replaced. The return value of 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 a at +position 0 of the first sequence should be deleted (-). The second +hunk says that the d at position 2 of the second sequence should +be inserted (+). The third hunk says that the h at position 4 +of the first sequence should be removed and replaced with the f +from position 4 of the second sequence. The other two hunks similarly.

        +

        diff may be passed an optional third parameter; this is a CODE +reference to a key generation function. See KEY GENERATION FUNCTIONS.

        +

        Additional parameters, if any, will be passed to the key generation +routine.

        +

        +

        +

        sdiff

        +
        +  @sdiffs     = sdiff( \@seq1, \@seq2 );
        +  $sdiffs_ref = sdiff( \@seq1, \@seq2 );
        +

        sdiff computes all necessary components to show two sequences +and their minimized differences side by side, just like the +Unix-utility 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 +(+: Element added, -: Element removed, u: Element unmodified, +c: Element changed) and the value of the old and new elements, to +be displayed side by side.

        +

        An 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' ] ]

        +

        sdiff may be passed an optional third parameter; this is a CODE +reference to a key generation function. See KEY GENERATION FUNCTIONS.

        +

        Additional parameters, if any, will be passed to the key generation +routine.

        +

        +

        +

        traverse_sequences

        +

        traverse_sequences is the most general facility provided by this +module; diff and 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. 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 $A[$i] +and $B[$j] which are equal and which are part of the LCS, there will be +some moment during the execution of traverse_sequences when arrow A is +pointing to $A[$i] and arrow B is pointing to $B[$j]. When this happens, +traverse_sequences will call the 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. traverse_sequences will advance that arrow and will +call the DISCARD_A or the DISCARD_B callback, depending on which arrow it +advanced. If both arrows point to elements that are not part of the LCS, then +traverse_sequences will advance one of them and call the appropriate +callback, but it is not specified which it will call.

        +

        The arguments to 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, +traverse_sequences will call the A_FINISHED callback when it advances +arrow B, if there is such a function; if not it will call DISCARD_B instead. +Similarly if arrow B finishes first. 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.

        +

        traverse_sequences may be passed an optional fourth parameter; this is a +CODE reference to a key generation function. See KEY GENERATION FUNCTIONS.

        +

        Additional parameters, if any, will be passed to the key generation function.

        +

        +

        +

        traverse_balanced

        +

        traverse_balanced is an alternative to 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 changes occurring as deletions on one +side followed immediatly by an insertion on the other side.

        +

        In addition to the +DISCARD_A, +DISCARD_B, and +MATCH +callbacks supported by traverse_sequences, traverse_balanced supports +a CHANGE callback indicating that one element got replaced by another:

        +
        +  traverse_sequences( \@seq1, \@seq2,
        +                     { MATCH => $callback_1,
        +                       DISCARD_A => $callback_2,
        +                       DISCARD_B => $callback_3,
        +                       CHANGE    => $callback_4,
        +                     } );
        +

        If no CHANGE callback is specified, traverse_balanced +will map CHANGE events to DISCARD_A and DISCARD_B actions, +therefore resulting in a similar behaviour as traverse_sequences +with different order of events.

        +

        traverse_balanced might be a bit slower than traverse_sequences, +noticable only while processing huge amounts of data.

        +

        The sdiff function of this module +is implemented as call to traverse_balanced.

        +

        +

        +
        +

        KEY GENERATION FUNCTIONS

        +

        diff, LCS, and 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.

        +

        +

        +
        +

        AUTHOR

        +

        This version by Ned Konz, perl@bike-nomad.com

        +

        +

        +
        +

        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.

        +

        +

        +
        +

        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

        +

        sdiff and traverse_balanced were written by Mike Schilli +<m@perlmeister.com>.

        +

        The algorithm is that described in +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.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Tools.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Tools.html new file mode 100644 index 0000000..2dd8904 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/File/Tools.html @@ -0,0 +1,583 @@ + + + + +GT::File::Tools - Export tools for dealing with files + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::File::Tools - Export tools for dealing with files

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::File::Tools qw/:all/;
        +    
        +    # Find all files in a users home directory.
        +    find "/home/user", sub { print shift };
        +    
        +    # Rename a file1 to file2.
        +    move "file1", "file2";
        +
        +    # Remove a list of files.
        +    del @files;
        +
        +    # Remove a users home directory
        +    deldir "/home/foo";
        +
        +    # Copy a file
        +    copy "file1", "file2";
        +
        +    # Recursively copy a directory.
        +    copy "/home/user", "/home/user.bak";
        +
        +    # Recursively make a directory.
        +    mkpath "/home/user/www/cgi-bin", 0755;
        +
        +    # Parse a filename into directory, file and is_relative components
        +    my ($dir, $file, $is_rel) = parsefile("/home/foo/file.txt");
        +
        +    # Get the file portion of a filename
        +    my $file = basename("/home/foo/file.txt");
        +
        +    # Get the directory portion of a filename.
        +    my $dir = dirname("/home/foo/file.txt");
        +
        +    # Use shell like expansion to get a list of absolute files.
        +    my @src = expand("*.c", "*.h");
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::File::Tools is designed to export requested functions into your namespace. +These function perform various file operations.

        +

        +

        +
        +

        FUNCTIONS

        +

        GT::File::Tools exports functions to your namespace. Here is a list of the +functions you can request to be exported.

        +

        +

        +

        find

        +

        find takes three parameters: directory to search in, callback to run for +each file and/or directory found, and a hash ref of options. Note: this is +the opposite order of File::Find's find() function! The following options +can be passed set:

        +
        +
        globbing + +
        +

        Expand filenames in the same way as the unix shell:

        +
        +
        +
        +    find("/home/a*", sub { print shift; }, { globbing => 1 });
        +
        +
        +

        would fine all home directories starting with the letter a. This option is +off by default.

        +
        + +
        error_handler + +
        +

        A code ref that is run whenever find encounters an error. If the callback +returns 0, find will stop immediately, otherwise find will continue +searching (default).

        +
        + +
        no_chdir + +
        +

        By default, find will chdir into the directories it is searching as +this results in a dramatic performance improvement. Upon completion, find +will chdir back to the original directory. This behavior is on by default.

        +
        + +
        dirs_first + +
        +

        This option controls the order find traverses. It defaults on, and means +find will go down directories first before looking at files. This is +essential for recursively deleting a directory.

        +
        + +
        files_only + +
        +

        This option tells find to run the callback only for each file found +and not for each directory. Off by default.

        +
        + +
        dirs_only + +
        +

        This option tells find to run the callback only for each directory found +and not for each file. Off by default.

        +
        + +
        max_depth + +
        +

        Defaults to 1000, this option controls how deep a directory structure find +will traverse. Meant mainly as a safety, and should not need to be adjusted.

        +
        + +
        +

        +

        +

        move

        +

        move has the same syntax as the system mv command:

        +
        +    move 'file', 'file2';
        +    move 'file1', 'file2', 'dir';
        +    move 'file1', 'file2', 'dir3', 'dir';
        +    move '*.c', 'dir', { globbing => 1 };
        +

        The only difference is the last argument can be a hash ref of options. The +following options are allowed:

        +
        +
        globbing + +
        error_handler + +
        max_depth + +
        +

        +

        +

        del

        +

        del has the same syntax as the rm system command, but it can not remove +directories. Use deldir below to recursively remove files.

        +
        +    del 'file1';
        +    del '*.c', { globbing => 1 };
        +    del 'a', 'b', 'c';
        +

        It takes a list of files or directories to delete, and an optional hash ref +of options. The following options are allowed:

        +
        +
        error_handler + +
        globbing + +
        +

        +

        +

        deldir

        +

        deldir is similiar to del, but allows recursive deletes of directories:

        +
        +    deldir 'file1';
        +    deldir 'dir11', 'dir2', 'dir3';
        +    deldir '/home/a*', { globbing => 1 };
        +

        It takes a list of files and/or directories to remove, and an optional hash ref +of options. The following options are allowed:

        +
        +
        error_handler + +
        globbing + +
        max_depth + +
        +

        +

        +

        copy

        +

        copy is similiar to the system cp command:

        +
        +    copy 'file1', 'file2';
        +    copy 'file1', 'file2', 'file3', 'dir1';
        +    copy '*.c', '/usr/local/src', { globbing => 1 };
        +    copy
        +

        It copies a source file to a destination file or directory. You can also +specify multiple source files, and copy them into a single directory. The +last argument should be a hash ref of options:

        +
        +
        set_perms + +
        +

        This option will preserve permissions. i.e.: if the original file is set 755, +the copy will also be set 755. It defaults on.

        +
        + +
        set_owner + +
        +

        This option will preserver file ownership. Note: you must be root to be able +to change ownerhsip of a file. This defaults off.

        +
        + +
        set_time + +
        +

        This option will preserve file modification time.

        +
        + +
        preserve_all + +
        +

        This option sets set_perms, set_owner and set_time on.

        +
        + +
        error_handler + +
        globbing + +
        max_depth + +
        +

        +

        +

        mkpath

        +

        mkpath recursively makes a directory. It takes the same arguments as +perl's mkdir():

        +
        +    mkpath("/home/alex/create/these/dirs", 0755) or die "Can't mkpath: $!";
        +

        For compatibility with older module versions, rmkdir() is an alias for +mkpath().

        +

        +

        +

        parsefile

        +

        This function takes any type of filename (relative, fullpath, etc) and +returns the inputs directory, file, and whether it is a relative path or +not. For example:

        +
        +    my ($directory, $file, $is_relative) = parsefile("../foo/bar.txt");
        +

        +

        +

        dirname

        +

        Returns the directory portion of a filename.

        +

        +

        +

        basename

        +

        Returns the last portion of a filename (typically, the filename itself without +any leading directory). A deprecated filename() alias for basename() also +exists.

        +

        +

        +

        expand

        +

        Uses shell like expansion to expand a list of filenames to full paths. For +example:

        +
        +    my @source   = expand("*.c", "*.h");
        +    my @homedirs = expand("/home/*");
        +

        If you pass in relative paths, expand always returns absolute paths of +expanded files. Note: this does not actually go to the shell.

        +

        +

        +
        +

        SEE ALSO

        +

        This module depends on perl's Cwd module for getting the current working +directory. It also uses GT::AutoLoader to load on demand functions.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Tools.pm,v 1.64 2007/02/10 17:45:41 sbeck Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter.html new file mode 100644 index 0000000..bea8c64 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter.html @@ -0,0 +1,379 @@ + + + + +/tmp/glinks/cgi/admin/GT/IPC/Filter.pm + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        SYNOPSIS

        +
        +    use GT::IPC::Filter::Foo;
        +
        +    my $filter = new GT::IPC::Filter::Foo(sub { my $out = shift ... });
        +    # -or-
        +    my $filter = new GT::IPC::Filter::Foo(
        +        output => sub { my $out = shift; .. },
        +        %options
        +    );
        +
        +    $filter->put(\$data);
        +
        +    $filter->flush;
        +

        +

        +
        +

        DESCRIPTION

        +

        This documents how to create a filter. The filter system documented here is +used for GT::IPC::Run, the GT::IPC::Run manpage, currently but could be useful for other +things relating to IO and IPC.

        +

        +

        +
        +

        METHODS

        +

        You will need to impliment three methods to create a filter. These methods are +pretty simple and strait forward.

        +

        +

        +

        new

        +

        This is your constructor. You will need to return an object. You should be able +to take a sigle argument as well as a hash of options. It isn't manditory but +it will keep the filter interface consistent.

        +

        The one argument form of new() is a code reference. This code reference will +be called with the data (in whatever form) after you filter it. You should +default the rest of your arguments to something reasonable. If there are no +reasonable defaults for your options you can stray from this and require the +hash form, but you should have a nice error for people that call you with the +one argument form:

        +
        +    $class->fatal(
        +        BADARGS => "This class does not accept the one argument form for filters"
        +    ) if @_ == 1;
        +

        The hash form should take a key output which will be the code reference +output will go to once you filter it. The rest of the keys are up to you. Try +to have reasonable defaults for the other keys, but fatal if there are any that +are required and not present.

        +

        +

        +

        put

        +

        This method is called with a scaler reference of the data you will be +filtering. You are expect to make changes to the data and call the output +code reference with the formatted data. For example GT::IPC::Filter::Line +calles the output code reference with each line of data, see +the GT::IPC::Filter::Line manpage. It is ok if you change the scalar reference passed +into you.

        +

        +

        +

        flush

        +

        flush() if called when the stream of data is at an end. Not arguments are +passed to it. You are expected send any data you are buffering to the output +code reference at this point, after filtering it if nessisary.

        +

        +

        +
        +

        SEE ALSO

        +

        See the GT::IPC::Run manpage, the GT::IPC::Filter::Line manpage, the GT::IPC::Filter::Stream manpage, +and the GT::IPC::Filter::Block manpage.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Block.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Block.html new file mode 100644 index 0000000..998d094 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Block.html @@ -0,0 +1,381 @@ + + + + +GT::IPC::Filter::Block - Implements block based filtering for output streams. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::IPC::Filter::Block - Implements block based filtering for output streams.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::IPC::Filter::Block;
        +
        +    my $filter = new GT::IPC::Filter::Block(
        +        sub { my $block = shift ... }
        +    );
        +    # -or-
        +    my $filter = new GT::IPC::Filter::Block(
        +        output => sub { my $out = shift; .. },
        +        block_size  => 512 # Default
        +    );
        +
        +    $filter->put(\$data);
        +
        +    $filter->flush;
        +

        +

        +
        +

        DESCRIPTION

        +

        Implements block based filtering to an output code reference. Used mainly in +GT::IPC::Run, the GT::IPC::Run manpage for details.

        +

        +

        +
        +

        METHODS

        +

        There are three methods (as with all filters in this class).

        +

        +

        +

        new

        +

        Takes either a single argument, which is a code reference to call output with, +or a hash of options.

        +
        +
        output + +
        +

        This is the code reference you would like called with each block of output. +The blocks are stripped of there ending before this is called.

        +
        + +
        block_size + +
        +

        This is the size of chunks of data you want your code reference called with. It +defaults to 512.

        +
        + +
        +

        +

        +

        put

        +

        This method takes a stream of data, it converted it into block based data using +the block_size you specified and passes each block to the code reference +specified by new(), see new. There is buffering that happens here.

        +

        +

        +

        flush

        +

        This method should be called last, when the data stream is over. It flushes the +remaining buffer out to the code reference.

        +

        +

        +
        +

        SEE ALSO

        +

        See the GT::IPC::Run manpage.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Line.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Line.html new file mode 100644 index 0000000..3be2195 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Line.html @@ -0,0 +1,391 @@ + + + + +GT::IPC::Filter::Line - Implements line based filtering for output streams. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::IPC::Filter::Line - Implements line based filtering for output streams.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::IPC::Filter::Line;
        +
        +    my $filter = new GT::IPC::Filter::Line(
        +        sub { my $line = shift ... }
        +    );
        +    # -or-
        +    my $filter = new GT::IPC::Filter::Line(
        +        output => sub { my $out = shift; .. },
        +        regex  => '\r?\n'
        +    );
        +
        +    $filter->put(\$data);
        +
        +    $filter->flush;
        +

        +

        +
        +

        DESCRIPTION

        +

        Implements line based filtering to an output code reference. Used mainly in +GT::IPC::Run, the GT::IPC::Run manpage for details.

        +

        +

        +
        +

        METHODS

        +

        There are three methods (as with all filters in this class).

        +

        +

        +

        new

        +

        Takes either a single argument, which is a code reference to call output with, +or a hash of options.

        +
        +
        output + +
        +

        This is the code reference you would like called with each line of output. The +lines are stripped of there ending before this is called.

        +
        + +
        regex + +
        +

        Specify the regex to use in order to determine the end of line sequence. This +regex is used in a split on the input stream. If you capture in this regex it +will break the output.

        +
        + +
        literal + +
        +

        Specifies a literal new line sequence. The only difference between this option +and the regex option is it is quotemeta, See perlfunc/quotemeta.

        +
        + +
        +

        +

        +

        put

        +

        This method takes a stream of data, it converted it into line based data and +passes each line to the code reference specified by new(), see new. +There is buffering that happens here because we have no way of knowing if the +output stream does not end with a new line, also streams almost always get +partial lines.

        +

        +

        +

        flush

        +

        This method should be called last, when the data stream is over. It flushes the +remaining buffer out to the code reference.

        +

        +

        +
        +

        SEE ALSO

        +

        See the GT::IPC::Run manpage.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Stream.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Stream.html new file mode 100644 index 0000000..a3de11b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Filter/Stream.html @@ -0,0 +1,371 @@ + + + + +GT::IPC::Filter::Block - Implements stream based filtering for output streams. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::IPC::Filter::Block - Implements stream based filtering for output streams.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::IPC::Filter::Stream;
        +
        +    my $filter = new GT::IPC::Filter::Block(
        +        sub { my $chunk = shift ... }
        +    );
        +    # -or-
        +    my $filter = new GT::IPC::Filter::Block(
        +        output => sub { my $chunk = shift; .. },
        +    );
        +
        +    $filter->put(\$data);
        +
        +    $filter->flush;
        +

        +

        +
        +

        DESCRIPTION

        +

        Implements stream based filtering to an output code reference. Used mainly in +GT::IPC::Run, the GT::IPC::Run manpage for details. Basically just a pass through to +your code reference.

        +

        +

        +
        +

        METHODS

        +

        There are three methods (as with all filters in this class).

        +

        +

        +

        new

        +

        Takes either a single argument, which is a code reference to call output with, +or a hash of options.

        +
        +
        output + +
        +

        This is the code reference you would like called with each output.

        +
        + +
        +

        +

        +

        put

        +

        This method takes a stream of data and passed it strait to your code reference. +There is no buffering that happens here.

        +

        +

        +

        flush

        +

        This method does nothing.

        +

        +

        +
        +

        SEE ALSO

        +

        See the GT::IPC::Run manpage.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Run.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Run.html new file mode 100644 index 0000000..8229892 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPC/Run.html @@ -0,0 +1,575 @@ + + + + +GT::IPC::Run - Run programs or code in parallel + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::IPC::Run - Run programs or code in parallel

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::IPC::Run;
        +
        +    # stderr and stdout filters default to a
        +    # GT::IPC::Line::Filter
        +    my $exit_code = run
        +        '/bin/ls',         # Program to run
        +        \*stdout_handle,   # stdout event
        +        \&stderr_handler,  # stderr event
        +        \$stdin;           # stdin
        +
        +    my $io = new GT::IPC::Run;
        +
        +    use GT::IPC::Filter::Line;
        +
        +    my $pid = $io->start(
        +        stdout => GT::IPC::Filter::Line->new(
        +            regex => "\r?\n",
        +            output => sub { print "Output: $_[0]\n" }
        +        ),
        +        program => sub { print "I got forked\n" },
        +    );
        +
        +    while ($io->do_one_loop) {
        +        if (defined(my $exit = $io->exit_code($pid))) {
        +            print "$pid exited ", ($exit>>8), "\n";
        +        }
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        Module to simplify running a program or code reference in parallel. Allows +catching and filtering the output of the program and filtering it.

        +

        +

        +
        +

        FUNCTIONS

        +

        GT::IPC::Run will import one function run() if you request it to.

        +

        +

        +

        run

        +

        Run is a simple interface to running a program or a subroutine in a separate +process and catching the output, both stderr and stdout. This function takes +four arguments, only the first argument is required.

        +
        +
        First Argument + +
        +

        The first argument to run() is the program to run or the code reference to +run. This argument can be one of three things.

        +
        +
        +

        If a code reference if passed as the first argument to run(), GT::IPC::Run +will fork off and run the code reference. You SHOULD NOT exit in the code +reference if you want your code to work on Windows. Calling die() is ok, +as your code is evaled. There are some things you CAN NOT do if you want your +code to work on Windows.

        +
        +
        +

        You SHOULD NOT make any calles to system() or exec(). For some reason, on +Windows, this breaks filehandle inheritance so all your output from that moment +on (including the system() or exec()) call will go to the real output +channel, STDERR or STDOUT.

        +
        +
        +

        You SHOULD NOT change STDERR or STDOUT. The child process on Windows can +affect the filehandles in the parent. This is probably because of the way +fork() on Windows is emulated as threads.

        +
        +
        +

        You probably should not fork() either, though this is not confirmed I +really doubt it will work the way you plan.

        +
        +
        +

        If an array reference is passed in it will be dereferenced and passed to +exec(). If a scalar is passed in it will be passed to exec().

        +
        +
        +

        On Windows the arguments are passed to Win32::Process::Create as the program +you wish to run. See the Win32::Process::Create manpage.

        +
        + +
        Second Argument + +
        +

        The second argument to run() is what you want to happen to STDOUT as it +comes in. This argument can be one of three things.

        +
        +
        +

        If it is a reference to a GT::IPC::Filter:: class, that will be used to call +your code. See the GT::IPC::Filter manpage for details.

        +
        +
        +

        If it is a code reference, a new GT::IPC::Filter::Line object will be created +and your code reference will be passed in. Exactly:

        +
        +
        +
        +    $out = GT::IPC::Filter::Line->new($out);
        +
        +
        +

        GT::IPC::Filter::Line will call your code reference for each line of output +from the program, the end of the line will be stripped. See +the GT::IPC::Filter::Line manpage for details.

        +
        +
        +

        If the argument is a scalar reference, again, a new GT::IPC::Filter::Line +object will be created. Exactly:

        +
        +
        +
        +    $out = GT::IPC::Filter::Line->new(sub { $$out .= $_[0] });
        +
        + +
        Third Argument + +
        +

        The third argument to run() is used to handle STDERR if and when what you +are running produces it.

        +
        +
        +

        This can be the exact same thing as the second argument, but will work on +STDERR.

        +
        + +
        Forth Argument + +
        +

        This argument is how to handle STDIN. It may be one of two things.

        +
        +
        +

        If it is a SCALAR, it will be printed to the input of what you are running.

        +
        + +
        +

        +

        +
        +

        METHODS

        +

        +

        +

        new

        +

        The is a simple method that takes no arguments and returns a GT::IPC::Run +object. It may take options in the future.

        +

        +

        +

        start

        +

        This is the more complex method to start a program running. When you call this +method, the program you specify is started right away and it's PID (process ID) +is returned to you. After you call this you will either need to call +do_loop() or do_one_loop() to start getting the programs or code +references output. See do_loop and do_one_loop else where in this +document.

        +

        This method takes a hash of arguments. The arguments are:

        +
        +
        program + +
        +

        The name of the program, or code reference you wish to run. This is treated +the same way as the first argument to run(). See run else where in +this document for a description of how this argument is treated.

        +
        + +
        stdout + +
        +

        This is how you want STDOUT treated. It can be the same things as the second +argument to run(). See run else where in this document for a +description of how this argument is treated.

        +
        + +
        stderr + +
        +

        This is how you want STDERR treated. It can be the same things as the third +argument to run(). See run else where in this document for a +description of how this argument is treated.

        +
        + +
        stdin + +
        +

        This argument is how to handle STDIN. It may be one of two things. It is +treated like the forth argument to run(). See run else where in this +document for a description of how this argument is treated.

        +
        + +
        reaper + +
        +

        This is a code reference that will be ran once a process has exited. Note: the +process may not be done sending us STDOUT or STDERR when it exits.

        +
        +
        +

        The code reference is called with the pid as it's first argument and the exit +status of the program for its second argument. The exit status is the same as +it is returned by waitpid(). The exit status is somewhat fiddled on Windows to +act the way you want it to, e.g. $exit_status >> 8 will be the +number the program exited with.

        +
        + +
        done_callback + +
        +

        This is a code reference that works similarly to reaper except that it is only +called after the child has died AND all STDOUT/STDERR output has been sent, +unlike reaper which is called on exit, regardless of any output that may still +be pending.

        +
        +
        +

        The code reference is called wih the pid and exit status of the program as its +two arguments.

        +
        + +
        +

        +

        +

        do_one_loop

        +

        This method takes one argument, the time to wait for select() to return +something in milliseconds. This does one select loop on all the processes. You +will need to called this after you call start(). Typically:

        +
        +    my $ipc = new GT::IPC::Run;
        +    my $pid = $ipc->start(program => 'ls');
        +    1 while $ipc->do_one_loop;
        +    my $exit_status = $ipc->exit_code($pid);
        +

        +

        +

        do_loop

        +

        This is similar to do_one_loop, except it does not return unless all +processes are finished. Almost the same as:

        +
        +    1 while $ipc->do_one_loop;
        +

        You can pass the wait time to do_loop() and it will be passed on to +do_one_loop. The wait time is in milliseconds.

        +

        +

        +

        exit_code

        +

        This method takes a pid as an argument and returns the exit status of that +processes pid. If the process has not exited yet or GT::IPC::Run did not launch +the process, returns undefined. The exit code returned by this is the same as +returned by waitpid. See perlfunc/waitpid and perlfunc/system.

        +

        +

        +
        +

        SEE ALSO

        +

        See perlipc, perlfunc/system, perlfunc/exec, perlfork, and +the Win32::Process manpage.

        +

        +

        +
        +

        MAINTAINER

        +

        Scott Beck

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPCountry.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPCountry.html new file mode 100644 index 0000000..b7d6cd3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/IPCountry.html @@ -0,0 +1,385 @@ + + + + +GT::IPCountry - Attempts to look up an IP's country using a variety of common +CPAN modules. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::IPCountry - Attempts to look up an IP's country using a variety of common +CPAN modules.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::IPCountry;
        +
        +    my $country = ip_to_country("209.139.239.160");
        +
        +    my ($country, $lookup_okay) = ip_to_country("209.139.239.160");
        +
        +    my $can_lookup = GT::IPCountry::lookup_possible();
        +

        +

        +
        +

        DESCRIPTION

        +

        This module takes an IP address and returns the country name the IP is reserved +for. This module itself does no actual lookup, but is simply a wrapper around +serveral CPAN modules. If none of the modules are available, it simply returns +the value undef.

        +

        +

        +
        +

        FUNCTIONS

        +

        +

        +

        ip_to_country

        +

        This method takes a country name and returns two elements: the country name, +and a true/false value indicating whether one of the lookup modules was +available. In scalar context just the country name is returned. A country +name of undef indicates that either the IP wasn't found, or no lookup module +was available.

        +

        ip_to_country is exported by default.

        +

        +

        +

        lookup_possible

        +

        This method returns a true/false value indicating whether or not an IP -> +Country lookup can be done. It corresponds directly to the second return value +of ip_to_country.

        +

        +

        +
        +

        MODULES

        +

        GT::IPCountry attempts to use the following modules, in order, to perform a +country lookup:

        +
        +
        Geo::IP + +
        +

        Uses Geo::IP for the lookup.

        +
        + +
        IP::Country + +
        +

        Uses IP::Country for the lookup. Note that because IP::Country only returns a +country code, this module will attempt to use Geography::Countries to determine +the country name. If Geography::Countries isn't installed, you'll just get a +country code.

        +
        + +
        Geo::IPfree + +
        +

        Uses Geo::IPfree for the lookup.

        +
        + +
        +

        +

        +
        +

        SEE ALSO

        +

        the Geo::IP manpage

        +

        the Geo::IPfree manpage

        +

        the IP::Country manpage

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: IPCountry.pm,v 1.1 2006/01/31 00:45:04 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Security.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Security.html new file mode 100644 index 0000000..ebd3b5b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Security.html @@ -0,0 +1,473 @@ + + + + +GT::Image::Security - Using the GD module, creates an image with text. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Image::Security - Using the GD module, creates an image with text.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Image::Security;
        +
        +    my $sec_image  = GT::Image::Security->new(
        +        fonts_path => "/home/aki/public_html/fonts",
        +        text       => "Hello World"
        +    ) or die $GT::Image::Security::error;
        +
        +    # some versions have gif, others png
        +    my $img_type = $sec_image->image_type();
        +
        +    print "Content-type: image/$img_type\n\n";
        +    print $sec_image->image_data;
        +

        +

        +
        +

        DESCRIPTION

        +

        Creates an image with specified text with mild alterations to rendered text +and background to reduce machine legibility. Whenever it can, it will attempt +to use TrueType fonts as the internal fonts tend to be difficult to read +and very limited in the number of transformations possible.

        +

        +

        +
        +

        INTERFACE

        +

        +

        +

        new

        +

        Creates a new security image handler with all options populated but does +not initialize the image. While most option are set by default or automatically, +certain behaviours can be forced quite easily by passing in a new value.

        +

        new will return undef if the GD module cannot be loaded. The exact details of the +error can be retreived from $GT::Image::Security::error or through the normal +GT::Base error function mechanism.

        +

        The following is a list of attributes that can be used to customize the output.

        +
        +
        text + +
        +

        Required. The string to be rendered in the image.

        +
        + +
        fonts_path + +
        +

        Optional. Required only if TrueType support is desired, it should be the path to the directory that holds .TTF files.

        +
        + +
        height + +
        +

        Optional. Typically automatically calculated, setting this will force the image to the specified height. (Output will be clipped if not tall enough)

        +
        + +
        width + +
        +

        Optional. Typically automatically calculated, setting this will force the image to the specified width. (Output will be clipped if not wide enough)

        +
        + +
        image_type + +
        +

        Optional. Set to png/jpeg/gif if the output format is important. If GD does not support the rendering method for the type of image, image_data will return undef and an error will be set.

        +
        + +
        exclude_fonts + +
        +

        Optional. Arrayref of filenames to ignore when scanning fonts for reasons such as illegibility. By default, the settings have been configured to work with the Bitstream Vera selection of fonts.

        +
        + +
        colour_steps + +
        +

        Optional. The number of steps between 0..255 in relation to the brightness of a single colour channel. By default, it has been set to 5 as older GD modules only support 256 colours.

        +
        + +
        invert + +
        +

        Optional. Typically automatically chosen, it will invert the colour selections so instead of dark colours for the foreground, brighter colours will be chosen instead. Similarly for the background, from bright, dark colours will be chosen instead.

        +
        + +
        max_x_wobble + +
        +

        Optional. Maximum number of pixels to randomly offset characters from ideal position along the horizontal axis.

        +
        + +
        max_y_wobble + +
        +

        Optional. Maximum number of pixels to randomly offset characters from ideal position along the vertical axis.

        +
        + +
        max_ang_wobble + +
        +

        Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random angular rotation for each character in the text.

        +
        + +
        base_pt + +
        +

        Optional. Only affects TrueType fonts, internal fonts will not use this feature. This sets the base point size of the font.

        +
        + +
        max_pt_wobble + +
        +

        Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random deviation from the base_pt size for each chacter rendered.

        +
        + +
        max_obfuscates + +
        +

        Optional. Usually set automatically, this sets the number of times the obfuscate_image action will be called uon the image. The action randomly draws a line or a rectangle on the image to provide chaff for any attempt to use OCR type software to extract the text from the image.

        +
        + +
        padding + +
        +

        Optional. The amount of extra pixel space that should be around the text.

        +
        + +
        display_chars + +
        +

        Optional. Typically shouldn't be used. However, it may be useful in situations where you would like to reproduce the image. After image_data has been called, squirrel away the value of $obj->{display_chars} and it will contain all the settings to be able to regenerate the image's core parts. Note: it does not store colour information so while the positions and size of the image would be the same, the colours would be different.

        +
        + +
        +

        +

        +

        image_type

        +

        Returns the type of image the module will attempt to produce. The results +can be ``png'', ``gif'', and ``jpeg'', fit for inserting into a mimetype header.

        +

        If an error occurs in the testing or no rendering methods could be found, +the function will return undef. The details on the error can be retrieved +through $obj->error

        +

        +

        +

        image_data

        +

        Returns a scalar with binary data which comprise the image. The image type +can be preset via the ``image_type'' attribute or accertained by the +image_type() method.

        +

        If an error occurs in the testing or no rendering methods could be found, +the function will return undef. The details on the error can be retrieved +through $obj->error

        +

        +

        +
        +

        SEE ALSO

        +

        GD, http://stein.cshl.org/WWW/software/GD/

        +

        +

        +
        +

        MAINTAINER

        +

        Aki Mimoto

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Security.pm,v 1.3 2006/11/03 18:55:35 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Size.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Size.html new file mode 100644 index 0000000..615f91e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Image/Size.html @@ -0,0 +1,618 @@ + + + + +GT::Image::Size - read the dimensions of an image in several popular formats + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Image::Size - read the dimensions of an image in several popular formats

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Image::Size;
        +    # Get the size of globe.gif
        +    ($globe_x, $globe_y) = imgsize("globe.gif");
        +    # Assume X=60 and Y=40 for remaining examples
        +
        +    use GT::Image::Size 'html_imgsize';
        +    # Get the size as 'width="X" height="Y"' for HTML generation
        +    $size = html_imgsize("globe.gif");
        +    # $size == 'width="60" height="40"'
        +
        +    use GT::Image::Size 'attr_imgsize';
        +    # Get the size as a list passable to routines in CGI.pm
        +    @attrs = attr_imgsize("globe.gif");
        +    # @attrs == ('-width', 60, '-height', 40)
        +
        +    use GT::Image::Size;
        +    # Get the size of an in-memory buffer
        +    ($buf_x, $buf_y) = imgsize(\$buf);
        +    # Assuming that $buf was the data, imgsize() needed a reference to a scalar
        +

        +

        +
        +

        DESCRIPTION

        +

        The GT::Image::Size library is based upon the wwwis script written by +Alex Knowles (alex@ed.ac.uk), a tool to examine HTML and add 'width' and +'height' parameters to image tags. The sizes are cached internally based on +file name, so multiple calls on the same file name (such as images used +in bulleted lists, for example) do not result in repeated computations.

        +

        GT::Image::Size provides three interfaces for possible import:

        +
        +
        imgsize(stream) + +
        +

        Returns a three-item list of the X and Y dimensions (width and height, in +that order) and image type of stream. Errors are noted by undefined +(undef) values for the first two elements, and an error string in the third. +The third element can be (and usually is) ignored, but is useful when +sizing data whose type is unknown.

        +
        + +
        html_imgsize(stream) + +
        +

        Returns the width and height (X and Y) of stream pre-formatted as a single +string 'width="X" height="Y"' suitable for addition into generated HTML IMG +tags. If the underlying call to imgsize fails, undef is returned. The +format returned is dually suited to both HTML and XHTML.

        +
        + +
        attr_imgsize(stream) + +
        +

        Returns the width and height of stream as part of a 4-element list useful +for routines that use hash tables for the manipulation of named parameters, +such as the Tk or CGI libraries. A typical return value looks like +("-width", X, "-height", Y). If the underlying call to imgsize fails, +undef is returned.

        +
        + +
        +

        By default, only imgsize() is exported. Any one or combination of the three +may be explicitly imported, or all three may be with the tag :all.

        +

        +

        +

        Input Types

        +

        The sort of data passed as stream can be one of three forms:

        +
        +
        string + +
        +

        If an ordinary scalar (string) is passed, it is assumed to be a file name +(either absolute or relative to the current working directory of the +process) and is searched for and opened (if found) as the source of data. +Possible error messages (see DIAGNOSTICS below) may include file-access +problems.

        +
        + +
        scalar reference + +
        +

        If the passed-in stream is a scalar reference, it is interpreted as pointing +to an in-memory buffer containing the image data.

        +
        +
        +
        +        # Assume that &read_data gets data somewhere (WWW, etc.)
        +        $img = &read_data;
        +        ($x, $y, $id) = imgsize(\$img);
        +        # $x and $y are dimensions, $id is the type of the image
        +
        + +
        Open file handle + +
        +

        The third option is to pass in an open filehandle (such as an object of +the IO::File class, for example) that has already been associated with +the target image file. The file pointer will necessarily move, but will be +restored to its original position before subroutine end.

        +
        +
        +
        +        # $fh was passed in, is IO::File reference:
        +        ($x, $y, $id) = imgsize($fh);
        +        # Same as calling with filename, but more abstract.
        +
        + +
        +

        +

        +

        Recognized Formats

        +

        GT::Image::Size natively understands and sizes data in the following formats:

        +
        +
        GIF + +
        JPG + +
        XBM + +
        XPM + +
        PPM family (PPM/PGM/PBM) + +
        XV thumbnails + +
        PNG + +
        MNG + +
        TIF + +
        BMP + +
        PSD (Adobe PhotoShop) + +
        SWF (ShockWave/Flash) + +
        PCD (Kodak PhotoCD, see notes below) + +
        +

        When using the imgsize interface, there is a third, unused value returned +if the programmer wishes to save and examine it. This value is the identity of +the data type, expressed as a 2-3 letter abbreviation as listed above. This is +useful when operating on open file handles or in-memory data, where the type +is as unknown as the size. The two support routines ignore this third return +value, so those wishing to use it must use the base imgsize routine.

        +

        +

        +

        Information Cacheing and $NO_CACHE

        +

        When a filename is passed to any of the sizing routines, the default behavior +of the library is to cache the resulting information. The modification-time of +the file is also recorded, to determine whether the cache should be purged and +updated. This was originally added due to the fact that a number of CGI +applications were using this library to generate attributes for pages that +often used the same graphical element many times over.

        +

        However, the cacheing can lead to problems when the files are generated +dynamically, at a rate that exceeds the resolution of the modification-time +value on the filesystem. Thus, the optionally-importable control variable +$NO_CACHE has been introduced. If this value is anything that evaluates to a +non-false value (be that the value 1, any non-null string, etc.) then the +cacheing is disabled until such time as the program re-enables it by setting +the value to false.

        +

        The parameter $NO_CACHE may be imported as with the imgsize routine, and +is also imported when using the import tag :all. If the programmer +chooses not to import it, it is still accessible by the fully-qualified package +name, $GT::Image::Size::NO_CACHE.

        +

        +

        +

        Sizing PhotoCD Images

        +

        With version 2.95, support for the Kodak PhotoCD image format is +included. However, these image files are not quite like the others. One file +is the source of the image in any of a range of pre-set resolutions (all with +the same aspect ratio). Supporting this here is tricky, since there is nothing +inherent in the file to limit it to a specific resolution.

        +

        The library addresses this by using a scale mapping, and requiring the user +(you) to specify which scale is preferred for return. Like the $NO_CACHE +setting described earlier, this is an importable scalar variable that may be +used within the application that uses GT::Image::Size. This parameter is called +$PCD_SCALE, and is imported by the same name. It, too, is also imported +when using the tag :all or may be referenced as +$GT::Image::Size::PCD_SCALE.

        +

        The parameter should be set to one of the following values:

        +
        +        base/16
        +        base/4
        +        base
        +        base4
        +        base16
        +        base64
        +

        Note that not all PhotoCD disks will have included the base64 +resolution. The actual resolutions are not listed here, as they are constant +and can be found in any documentation on the PCD format. The value of +$PCD_SCALE is treated in a case-insensitive manner, so base is the same +as Base or BaSe. The default scale is set to base.

        +

        Also note that the library makes no effort to read enough of the PCD file to +verify that the requested resolution is available. The point of this library +is to read as little as necessary so as to operate efficiently. Thus, the only +real difference to be found is in whether the orientation of the image is +portrait or landscape. That is in fact all that the library extracts from the +image file.

        +

        +

        +

        Controlling Behavior with GIF Images

        +

        GIF images present a sort of unusual situation when it comes to reading size. +Because GIFs can be a series of sub-images to be isplayed as an animated +sequence, what part does the user want to get the size for?

        +

        When dealing with GIF files, the user may control the behavior by setting the +global value $Image::Size::GIF_BEHAVIOR. Like the PCD setting, this may +be imported when loading the library. Three values are recognized by the +GIF-handling code:

        +
          +
        1. +

          This is the default value. When this value is chosen, the returned dimensions +are those of the ``screen''. The ``screen'' is the display area that the GIF +declares in the first data block of the file. No sub-images will be greater +than this in size; if they are, the specification dictates that they be +cropped to fit within the box.

          +

          This is also the fastest method for sizing the GIF, as it reads the least +amount of data from the image stream.

          +
        2. +
        3. +

          If this value is set, then the size of the first sub-image within the GIF is +returned. For plain (non-animated) GIF files, this would be the same as the +screen (though it doesn't have to be, strictly-speaking).

          +

          When the first image descriptor block is read, the code immediately returns, +making this only slightly-less efficient than the previous setting.

          +
        4. +
        5. +

          If this value is chosen, then the code loops through all the sub-images of the +animated GIF, and returns the dimensions of the largest of them.

          +

          This option requires that the full GIF image be read, in order to ensure that +the largest is found.

          +
        6. +
        +

        Any value outside this range will produce an error in the GIF code before any +image data is read.

        +

        The value of dimensions other than the view-port (``screen'') is dubious. +However, some users have asked for that functionality.

        +

        +

        +
        +

        DIAGNOSTICS

        +

        The base routine, imgsize, returns undef as the first value in its list +when an error has occurred. The third element contains a descriptive +error message.

        +

        The other two routines simply return undef in the case of error.

        +

        +

        +
        +

        MORE EXAMPLES

        +

        The attr_imgsize interface is also well-suited to use with the Tk +extension:

        +
        +    $image = $widget->Photo(-file => $img_path, attr_imgsize($img_path));
        +

        Since the Tk::Image classes use dashed option names as CGI does, no +further translation is needed.

        +

        This package is also well-suited for use within an Apache web server context. +File sizes are cached upon read (with a check against the modified time of +the file, in case of changes), a useful feature for a mod_perl environment +in which a child process endures beyond the lifetime of a single request. +Other aspects of the mod_perl environment cooperate nicely with this +module, such as the ability to use a sub-request to fetch the full pathname +for a file within the server space. This complements the HTML generation +capabilities of the CGI module, in which CGI::img wants a URL but +attr_imgsize needs a file path:

        +
        +    # Assume $Q is an object of class CGI, $r is an Apache request object.
        +    # $imgpath is a URL for something like "/img/redball.gif".
        +    $r->print($Q->img({ -src => $imgpath,
        +                        attr_imgsize($r->lookup_uri($imgpath)->filename) }));
        +

        The advantage here, besides not having to hard-code the server document root, +is that Apache passes the sub-request through the usual request lifecycle, +including any stages that would re-write the URL or otherwise modify it.

        +

        +

        +
        +

        CAVEATS

        +

        Caching of size data can only be done on inputs that are file names. Open +file handles and scalar references cannot be reliably transformed into a +unique key for the table of cache data. Buffers could be cached using the +MD5 module, and perhaps in the future I will make that an option. I do not, +however, wish to lengthen the dependancy list by another item at this time.

        +

        +

        +
        +

        SEE ALSO

        +

        http://www.tardis.ed.ac.uk/~ark/wwwis/ for a description of wwwis +and how to obtain it.

        +

        +

        +
        +

        AUTHORS

        +

        Perl module interface by Randy J. Ray (rjray@blackperl.com), original +image-sizing code by Alex Knowles (alex@ed.ac.uk) and Andrew Tong +(werdna@ugcs.caltech.edu), used with their joint permission.

        +

        Some bug fixes submitted by Bernd Leibing (bernd.leibing@rz.uni-ulm.de). +PPM/PGM/PBM sizing code contributed by Carsten Dominik +(dominik@strw.LeidenUniv.nl). Tom Metro (tmetro@vl.com) re-wrote the JPG +and PNG code, and also provided a PNG image for the test suite. Dan Klein +(dvk@lonewolf.com) contributed a re-write of the GIF code. Cloyce Spradling +(cloyce@headgear.org) contributed TIFF sizing code and test images. Aldo +Calpini (a.calpini@romagiubileo.it) suggested support of BMP images (which +I really should have already thought of :-) and provided code to work +with. A patch to allow html_imgsize to produce valid output for XHTML, as +well as some documentation fixes was provided by Charles Levert +(charles@comm.polymtl.ca). The ShockWave/Flash support was provided by +Dmitry Dorofeev (dima@yasp.com). Though I neglected to take note of who +supplied the PSD (PhotoShop) code, a bug was identified by Alex Weslowski +<aweslowski@rpinteractive.com>, who also provided a test image. PCD support +was adapted from a script made available by Phil Greenspun, as guided to my +attention by Matt Mueller mueller@wetafx.co.nz. A thorough read of the +documentation and source by Philip Newton Philip.Newton@datenrevision.de +found several typos and a small buglet. Ville Skyttä (ville.skytta@iki.fi) +provided the MNG and the Image::Magick fallback code.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Installer.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Installer.html new file mode 100644 index 0000000..74924eb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Installer.html @@ -0,0 +1,717 @@ + + + + +GT::Installer - Performs initial installs for GTI products + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Installer - Performs initial installs for GTI products

        +

        +

        +
        +

        SYNOPSIS

        +
        +    main();
        +
        +    sub main {
        +        my $format = 'scroll1';
        +        my $installer = GT::Installer->new(
        +            product        => 'Gossamer Mail',
        +            version        => '2.0.0 beta 1',
        +            load_defaults  => \&load_defaults,
        +            load_config    => \&load_config,
        +            save_config    => \&save_config,
        +            checksums      => "<%Data Path%>/admin/checksums",
        +            welcome_format => $format
        +        );
        +
        +        $installer->add_config_message(q|
        +    This should be the system path and url (start with http://) 
        +    to the directory where your admin files are. No trailing 
        +    slash please.|, $format);
        +
        +        $installer->add_config(
        +            type     => 'path',
        +            key      => "Admin Path",
        +            message  => 'Admin Path',
        +        );
        +    }
        +    # Regex to path keys. These regexs have to capture
        +    # the file in $1
        +        $installer->install_to(
        +            '^admin/(.*)$'  => 'Admin Path',
        +            '^user/(.*)$'   => 'User Path',
        +            '^batch/(.*)$'  => 'Batch Path',
        +            '^data/(.*)$'   => 'Data Path',
        +            '^images/(.*)$' => 'Images Path',
        +        );
        +        
        +        $installer->add_upgrade(
        +            message         => 'Program Files. e.g. .pm, .pl and .cgi files',
        +            file_list       => '\.(?:pl|cgi|pm)$'
        +        );
        +        $installer->add_upgrade(skip => 'ConfigData\.pm$');
        +        $installer->perform;
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Installer is an installer class for all Gossamer Threads +products. It will handle both a command line interface and a +CGI inteface.

        +

        All intallation directives are specified at the start and are +called for each CGI request if being ran in CGI mode.

        +

        +

        +

        Creating a new GT::Installer object

        +

        There are several options when creating a new GT::Installer +object. All options are in the form of key value pairs. The +options can be passed in as a flattened hash or as a hash +reference.

        +

        There are two options that must be specified. These are +product and version. All other options are optional.

        +

        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 = new GT::SQL '/path/to/def';
        +

        or you can pass in a hash or hash ref and specify options:

        +
        +    $db = new GT::SQL {
        +                        def_path => '/path/to/def',
        +                        cache    => 1,
        +                        debug    => 1,
        +                        subclass => 1
        +                    );
        +

        You must specify def_path. Setting cache => 1, will result in +all table or relation objects to be cached which can improve +performance.

        +

        Setting subclass => 0 or subclass => 1 will enable or disable +the ability to subclass any of the objects GT::SQL creates. The +default behaviour is 1.

        +

        GT::SQL has advanced debugging, and setting it to 1 should be +adequate for most operations.

        +
        +
        product + +
        +

        Specifies the name of the product. This name is used in the +welcome message and in various parts of the dialogue.

        +
        +
        +
        +    product => 'Gossamer Mail'
        +
        + +
        version + +
        +

        This is the version of the product. It is used on the startup +screen to tell the user what version we are installing or +upgrading to.

        +
        +
        +
        +    version => '2.0.0 beta 1'
        +
        + +
        load_defaults + +
        +

        This is a code reference that is called when installing. It +is used to defaults for prompts you have set up. The only +argument to this code reference if the installer object +which has method to assist in setting up defaults for the +different configuration options that you would specify.

        +
        +
        +

        If you return false from this code reference the error is +expected to be in GT::Installer::error. GT::Installer inherets +from GT::Base so you can just call the error method on the +object and return it to achieve this.

        +
        +
        +
        +    load_defaults => \&load_defaults
        +
        + +
        load_config + +
        +

        This is another code reference. It is called when the user +specifies that they are doing an upgrade. The argument to +this callback is the installer object. The path to the admin +directory of the last install is a key in the installer object +admin_path. In this code reference you will need to correlate +all the config option keys to the values in your config file. +See the example included in this pod for a possible why to +do this.

        +
        +
        +
        +    load_config => \&load_config
        +
        +
        +

        If you return false from this code reference the error is +expected to be in GT::Installer::error. GT::Installer inherets +from GT::Base so you can just call the error method on the +object and return it to achieve this.

        +
        + +
        save_config + +
        +

        This is a code reference that is called after an install or +upgrade. It gives you the opertunity to save any user input into +there new/old config file.

        +
        +
        +
        +    save_config => \&save_config
        +
        + +
        checksums + +
        +

        This should be set to the full system path to the checksum file. +If this is not set checksums will not be used, which makes +the upgrade questions usless and all files will be overridden. +There is no possible way you can know the full path to this file +at the point you set it. You can specify tags in this path +that will get replaced with what the user entered. The tags +are similar to the GT::Template manpage tags in that they start with +&lt;% and end with %&gt;. No other the GT::Template manpage tags conventions +are used.

        +
        +
        +
        +    checksums => "<%Data Path%>/admin/checksums"
        +
        + +
        welcome_format + +
        +

        This is the welcome format. There are named formats that are +used in GT::Installer for most command line output. This +is the one that is used for the initial message. This is not +used in CGI mode.

        +
        +
        +

        There are currently 4 formats (more to come :)). There are:

        +
        +
        +
        scroll1 + +
        +
        +     _________________________________________________________________
        +    /\                                                                \
        +    \_|                                                                |
        +      |                                                                |
        +      | This is the scroll1 format                                     |
        +      |  ______________________________________________________________|_
        +      \_/_______________________________________________________________/
        +
        +
        scroll2 + +
        +
        +     __^__                                                                __^__
        +    ( ___ )--------------------------------------------------------------( ___ )
        +     | / |                                                                | \ |
        +     | / | This is the scroll2 format                                     | \ |
        +     |___|                                                                |___|
        +    (_____)--------------------------------------------------------------(_____)
        +
        +
        professional + +
        +
        +     #================================================================#
        +     =                                                                =
        +     =  This is the professional format                               =
        +     #================================================================#
        +
        +
        none + +
        +

        This format just performs line wraps. Has no outline :(

        +
        + +
        +
        +

        +

        +

        add_config - Adding configuration options.

        +

        There are 3 methods for adding user prompts. When I say user promts I +mean that in the telnet sence, in CGI mode it is just a table row.

        +

        This is the method you will be calling for every install option the +user should specify. This method takes it's arguments as key value +pair. The arguments can either be in the form of a flatened hash or +a hash reference.

        +
        +    $installer->add_config(
        +        type            => 'url',
        +        key             => "Admin URL",
        +        message         => 'Admin URL',
        +        telnet_callback => \&telnet_callback,
        +    );
        +

        Each key in the hash defines an attribute of the user prompt.

        +
        +
        type + +
        +

        The type attribute should be one of the built in input types. There is +currently no way to specify your own type. If this becomes a problem +it will be added. The built in types are as follows.

        +
        +
        +
        +    url           - User specifies a URL.
        +    ftp           - User specifies an FTP URL.
        +    path          - User specifies a Path to something on the system.
        +    message       - This is the same as calling the add_config_message 
        +                    method.
        +    create_dirs   - This is a yes/no answer on weather the user wants the
        +                    directories for this install created.
        +    email         - User specifies and email address. This is commonly 
        +                    used to prompt for the admin email address.
        +    reg_number    - User specifies the registration number they recieved
        +                    from us when they paid for the product.
        +    email_support - Specify either the path to sendmail or the hostname
        +                    of an smtp server. What is specified with be in the 
        +                    config hash as email_support. The key default for
        +                    this option is Mailer.
        +    perl_path     - Specify the path to perl on this system.
        +
        + +
        key + +
        +

        Each item the user enters is stored in a hash in the installer object. +This hash is called config. This specifies the key used in that hash +to store this user option.

        +
        +
        +

        This key is also used at the end of the telnet install to display +the options the user has specified for the install.

        +
        +
        +

        You will be accessing these keys in your configuration callbacks to +either set defaults or save the user specified options in your config +file. See the complete example below to see how this is used.

        +
        + +
        message + +
        +

        This is the message the user is pompted with in telnet. From the with +this appears on the left of the form the user fills out.

        +
        +
        +

        This will default to the value of the key if not specified

        +
        + +
        telnet_callback + +
        +

        This is a code reference that, if specified, will be ran after the user +enteres the information. You can use this to tweek the other option +defaults. If this method returns false the user will be reprompted for +the information. So you can effectivly use this to validate command +line input.

        +
        + +
        +

        +

        +

        add_config_message - Add a configuration message.

        +

        This is a method to add a configuration message. This message is +displayed to the user in telnet in the order you specify it. No prompt +is performed for these messages.

        +

        This is a shortcut function that is the same as specifing:

        +
        +    $installer->add_config(
        +        type    => 'message',
        +        message => 'This message is displayed to the user',
        +        format  => 'none'
        +    );
        +

        The arguments to this function are (message, format). Message is what +is displayed, format is the format used. See above for a list of +formats.

        +
        +    $installer->add_config_message(q|My configuration message.|, 'professional');
        +

        +

        +

        install_exit_message - Add an exit message for installs.

        +

        This is the message that is displayed after the installation is +complete. This message uses the same convention for tags as the +checksum option for the constructor method. Any keys that are set +during the install will be available as tags here. The second argument +to this method is an optional format (used in telnet see above).

        +
        +    $installer->install_exit_message(q|
        +    To run the setup, point your browser to: 
        +    <a href="<%Admin URL%>/admin.cgi"><%Admin URL%>/admin.cgi</a>
        +    |, 'scroll2');
        +

        +

        +

        install_to - Specify where to untar files to.

        +

        The way this options is specified is a bit strange and my be rewritten. +It takes it arguments as a hash of regular expressions to keys. The +keys are the keys you specified with add_config(). The regexs are matched +against the relative path in the tar file. Anything captured in $1 is +appended to the value the user entered for that regexs key. For example +is you specify a key Admin Path such as

        +
        +    $installer->add_config(
        +        type  => 'path',
        +        key   => 'Admin Path'
        +    );
        +

        You could then use the key like:

        +
        +    $installer->install_to(
        +        '^admin/(.*)' => 'Admin Path'
        +    );
        +

        This would replace admin/ in the relative path in the tar file with what +the user entered for the Admin Path prompt.

        +

        +

        +

        use_lib - Set the use lib path for addition to all .pl and .cgi files.

        +

        The argument to this should be a key specified with add_config(). The +path the user entered for that config is added to all .cgi and .pl files +in a use lib '' statement. Followig the example above:

        +
        +    $installer->use_lib('Admin Path');
        +

        All .cgi and .pl file in the install will now have

        +
        +    use lib '/home/bline/projects/library';
        +

        added to them assuming the path the user entered for that config option was +/home/bline/projects/library'.

        +

        You can set $GT::Installer::USE_LIB_SPACES to something other than the default +4 spaces to alter the number of spaces that will be put before the ``use lib''. +Please be careful - if you set this to something other than whitespace you are +asking for trouble or being an 1337 h4xx0r.

        +

        +

        +

        replace_path - Generic method to replace paths upon install

        +

        The argument should be a hash of key => value replacements that should be +made upon installation.

        +
        +    $installer->replace_path(
        +        '../private/ConfigData.pm' => '<%Private_Path%>/ConfigData.pm'
        +    );
        +

        This will replace all occurrences of ../private/ConfigData.pm with what the +user entered in <%Private_Path%>.

        +

        +

        +

        add_upgrade - Adding upgrade options.

        +

        This is a method for grouping files and or directories under user prompted +upgrade options. This is NOT designed to be a complete upgrade system. It +handled basic checksuming, overwrites and backup. This should probably not +be used for a major upgrade.

        +

        more to come...

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Installer.pm,v 1.98 2008/11/18 03:10:03 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON.html new file mode 100644 index 0000000..e33b787 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON.html @@ -0,0 +1,1621 @@ + + + + +GT::JSON - JSON encoder/decoder + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::JSON - JSON (JavaScript Object Notation) encoder/decoder

        +

        +

        +
        +

        DISCLAIMER

        +

        This module is based off of Makamaka Hannyaharamitu's JSON module (2.12).

        +

        +

        +
        +

        SYNOPSIS

        +
        + use GT::JSON; # imports encode_json, decode_json, to_json and from_json.
        +
        + $json_text   = to_json($perl_scalar);
        + $perl_scalar = from_json($json_text);
        +
        + # option-acceptable
        + $json_text   = to_json($perl_scalar, {ascii => 1});
        + $perl_scalar = from_json($json_text, {utf8 => 1});
        +
        + # OOP
        + $json = new GT::JSON;
        +
        + $json_text   = $json->encode($perl_scalar);
        + $perl_scalar = $json->decode($json_text);
        +
        + # pretty-printing
        + $json_text = $json->pretty->encode($perl_scalar);
        +
        + # simple interface
        + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
        + $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
        +
        + # If you want to use PP only support features, call with '-support_by_pp'
        + # When XS unsupported feature is enable, using PP de/encode.
        +
        + use GT::JSON -support_by_pp;
        +

        +

        +
        +

        VERSION

        +
        +    2.14
        +

        This version is compatible with JSON::XS 2.22 and later.

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::JSON (JavaScript Object Notation) is a simple data format. +See to http://www.json.org/ and RFC4627(http://www.ietf.org/rfc/rfc4627.txt).

        +

        This module converts Perl data structures to JSON and vice versa using either +the JSON::XS manpage or the GT::JSON::PP manpage.

        +

        JSON::XS is the fastest and most proper JSON module on CPAN which must be +compiled and installed in your environment. +GT::JSON::PP is a pure-Perl module which is bundled in this distribution and +has a strong compatibility to JSON::XS.

        +

        This module try to use JSON::XS by default and fail to it, use GT::JSON::PP instead. +So its features completely depend on JSON::XS or GT::JSON::PP.

        +

        See to BACKEND MODULE DECISION.

        +

        To distinguish the module name 'GT::JSON' and the format type JSON, +the former is quoted by C<> (its results vary with your using media), +and the latter is left just as it is.

        +

        Module name : GT::JSON

        +

        Format type : JSON

        +

        +

        +

        FEATURES

        +
          +
        • correct unicode handling + +

          This module (i.e. backend modules) knows how to handle Unicode, documents +how and when it does so, and even documents what ``correct'' means.

          +

          Even though there are limitations, this feature is available since Perl version 5.6.

          +

          JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions +GT::JSON should call GT::JSON::PP as the backend which can be used since Perl 5.005.

          +

          With Perl 5.8.x GT::JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem, +GT::JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available. +See to UNICODE HANDLING ON PERLS in the GT::JSON::PP manpage for more information.

          +

          See also to A FEW NOTES ON UNICODE AND PERL in the JSON::XS manpage +and ENCODING/CODESET_FLAG_NOTES in the JSON::XS manpage.

          +
        • +
        • round-trip integrity + +

          When you serialise a perl data structure using only data types supported by JSON, +the deserialised data structure is identical on the Perl level. +(e.g. the string ``2.0'' doesn't suddenly become ``2'' just because it looks +like a number). There minor are exceptions to this, read the MAPPING +section below to learn about those.

          +
        • +
        • strict checking of JSON correctness + +

          There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default (the latter is a security +feature).

          +

          See to FEATURES in the JSON::XS manpage and FEATURES in the GT::JSON::PP manpage.

          +
        • +
        • fast + +

          This module returns a JSON::XS object itself if avaliable. +Compared to other JSON modules and other serialisers such as Storable, +JSON::XS usually compares favourably in terms of speed, too.

          +

          If not avaliable, GT::JSON returns a GT::JSON::PP object instead of JSON::XS and +it is very slow as pure-Perl.

          +
        • +
        • simple to use + +

          This module has both a simple functional interface as well as an +object oriented interface interface.

          +
        • +
        • reasonably versatile output formats + +

          You can choose between the most compact guaranteed-single-line format possible +(nice for simple line-based protocols), a pure-ASCII format (for when your transport +is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed +format (for when you want to read that stuff). Or you can combine those features +in whatever way you like.

          +
        • +
        +

        +

        +
        +

        FUNCTIONAL INTERFACE

        +

        Some documents are copied and modified from FUNCTIONAL INTERFACE in the JSON::XS manpage. +to_json and from_json are additional functions.

        +

        +

        +

        to_json

        +
        +   $json_text = to_json($perl_scalar)
        +

        Converts the given Perl data structure to a json string.

        +

        This function call is functionally identical to:

        +
        +   $json_text = GT::JSON->new->encode($perl_scalar)
        +

        Takes a hash reference as the second.

        +
        +   $json_text = to_json($perl_scalar, $flag_hashref)
        +

        So,

        +
        +   $json_text = encode_json($perl_scalar, {utf8 => 1, pretty => 1})
        +

        equivalent to:

        +
        +   $json_text = GT::JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
        +

        +

        +

        from_json

        +
        +   $perl_scalar = from_json($json_text)
        +

        The opposite of to_json: expects a json string and tries +to parse it, returning the resulting reference.

        +

        This function call is functionally identical to:

        +
        +    $perl_scalar = GT::JSON->decode($json_text)
        +

        Takes a hash reference as the second.

        +
        +    $perl_scalar = from_json($json_text, $flag_hashref)
        +

        So,

        +
        +    $perl_scalar = from_json($json_text, {utf8 => 1})
        +

        equivalent to:

        +
        +    $perl_scalar = GT::JSON->new->utf8(1)->decode($json_text)
        +

        +

        +

        encode_json

        +
        +    $json_text = encode_json $perl_scalar
        +

        Converts the given Perl data structure to a UTF-8 encoded, binary string.

        +

        This function call is functionally identical to:

        +
        +    $json_text = GT::JSON->new->utf8->encode($perl_scalar)
        +

        +

        +

        decode_json

        +
        +    $perl_scalar = decode_json $json_text
        +

        The opposite of encode_json: expects an UTF-8 (binary) string and tries +to parse that as an UTF-8 encoded JSON text, returning the resulting +reference.

        +

        This function call is functionally identical to:

        +
        +    $perl_scalar = GT::JSON->new->utf8->decode($json_text)
        +

        +

        +

        GT::JSON::is_bool

        +
        +    $is_boolean = GT::JSON::is_bool($scalar)
        +

        Returns true if the passed scalar represents either GT::JSON::true or +GT::JSON::false, two constants that act like 1 and 0 respectively +and are also used to represent JSON true and false in Perl strings.

        +

        +

        +

        GT::JSON::true

        +

        Returns JSON true value which is blessed object. +It isa GT::JSON::Boolean object.

        +

        +

        +

        GT::JSON::false

        +

        Returns JSON false value which is blessed object. +It isa GT::JSON::Boolean object.

        +

        +

        +

        GT::JSON::null

        +

        Returns undef.

        +

        See MAPPING, below, for more information on how JSON values are mapped to +Perl.

        +

        +

        +
        +

        COMMON OBJECT-ORIENTED INTERFACE

        +

        +

        +

        new

        +
        +    $json = new GT::JSON
        +

        Returns a new GT::JSON object inherited from either JSON::XS or GT::JSON::PP +that can be used to de/encode JSON strings.

        +

        All boolean flags described below are by default disabled.

        +

        The mutators for flags all return the JSON object again and thus calls can +be chained:

        +
        +   my $json = GT::JSON->new->utf8->space_after->encode({a => [1,2]})
        +   => {"a": [1, 2]}
        +

        +

        +

        ascii

        +
        +    $json = $json->ascii([$enable])
        +
        +    $enabled = $json->get_ascii
        +

        If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.

        +

        If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format.

        +

        This feature depends on the used Perl version and environment.

        +

        See to UNICODE HANDLING ON PERLS in the GT::JSON::PP manpage if the backend is PP.

        +
        +  GT::JSON->new->ascii(1)->encode([chr 0x10401])
        +  => ["\ud801\udc01"]
        +

        +

        +

        latin1

        +
        +    $json = $json->latin1([$enable])
        +
        +    $enabled = $json->get_latin1
        +

        If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.

        +

        If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags.

        +
        +  GT::JSON->new->latin1->encode (["\x{89}\x{abc}"]
        +  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
        +

        +

        +

        utf8

        +
        +    $json = $json->utf8([$enable])
        +
        +    $enabled = $json->get_utf8
        +

        If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O.

        +

        In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627.

        +

        If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.

        +

        Example, output UTF-16BE-encoded JSON:

        +
        +  use Encode;
        +  $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
        +

        Example, decode UTF-32LE-encoded JSON:

        +
        +  use Encode;
        +  $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
        +

        See to UNICODE HANDLING ON PERLS in the GT::JSON::PP manpage if the backend is PP.

        +

        +

        +

        pretty

        +
        +    $json = $json->pretty([$enable])
        +

        This enables (or disables) all of the indent, space_before and +space_after (and in the future possibly more) flags in one call to +generate the most readable (or most compact) form possible.

        +

        Equivalent to:

        +
        +   $json->indent->space_before->space_after
        +

        The indent space length is three and JSON::XS cannot change the indent +space length.

        +

        +

        +

        indent

        +
        +    $json = $json->indent([$enable])
        +
        +    $enabled = $json->get_indent
        +

        If $enable is true (or missing), then the encode method will use a multiline +format as output, putting every array member or object/hash key-value pair +into its own line, identing them properly.

        +

        If $enable is false, no newlines or indenting will be produced, and the +resulting JSON text is guarenteed not to contain any newlines.

        +

        This setting has no effect when decoding JSON texts.

        +

        The indent space length is three. +With GT::JSON::PP, you can also access indent_length to change indent space length.

        +

        +

        +

        space_before

        +
        +    $json = $json->space_before([$enable])
        +
        +    $enabled = $json->get_space_before
        +

        If $enable is true (or missing), then the encode method will add an extra +optional space before the : separating keys from values in JSON objects.

        +

        If $enable is false, then the encode method will not add any extra +space at those places.

        +

        This setting has no effect when decoding JSON texts.

        +

        Example, space_before enabled, space_after and indent disabled:

        +
        +   {"key" :"value"}
        +

        +

        +

        space_after

        +
        +    $json = $json->space_after([$enable])
        +
        +    $enabled = $json->get_space_after
        +

        If $enable is true (or missing), then the encode method will add an extra +optional space after the : separating keys from values in JSON objects +and extra whitespace after the , separating key-value pairs and array +members.

        +

        If $enable is false, then the encode method will not add any extra +space at those places.

        +

        This setting has no effect when decoding JSON texts.

        +

        Example, space_before and indent disabled, space_after enabled:

        +
        +   {"key": "value"}
        +

        +

        +

        relaxed

        +
        +    $json = $json->relaxed([$enable])
        +
        +    $enabled = $json->get_relaxed
        +

        If $enable is true (or missing), then decode will accept some +extensions to normal JSON syntax (see below). encode will not be +affected in anyway. Be aware that this option makes you accept invalid +JSON texts as if they were valid!. I suggest only to use this option to +parse application-specific files written by humans (configuration files, +resource files etc.)

        +

        If $enable is false (the default), then decode will only accept +valid JSON texts.

        +

        Currently accepted extensions are:

        +
          +
        • list items can have an end-comma + +

          JSON separates array elements and key-value pairs with commas. This +can be annoying if you write JSON texts manually and want to be able to +quickly append elements, so this extension accepts comma at the end of +such items not just between them:

          +
          +   [
          +      1,
          +      2, <- this comma not normally allowed
          +   ]
          +   {
          +      "k1": "v1",
          +      "k2": "v2", <- this comma not normally allowed
          +   }
          +
        • +
        • shell-style '#'-comments + +

          Whenever JSON allows whitespace, shell-style comments are additionally +allowed. They are terminated by the first carriage-return or line-feed +character, after which more white-space and comments are allowed.

          +
          +  [
          +     1, # this comment not allowed in JSON
          +        # neither this one...
          +  ]
          +
        • +
        +

        +

        +

        canonical

        +
        +    $json = $json->canonical([$enable])
        +
        +    $enabled = $json->get_canonical
        +

        If $enable is true (or missing), then the encode method will output JSON objects +by sorting their keys. This is adding a comparatively high overhead.

        +

        If $enable is false, then the encode method will output key-value +pairs in the order Perl stores them (which will likely change between runs +of the same script).

        +

        This option is useful if you want the same data structure to be encoded as +the same JSON text (given the same overall settings). If it is disabled, +the same hash might be encoded differently even if contains the same data, +as key-value pairs have no inherent ordering in Perl.

        +

        This setting has no effect when decoding JSON texts.

        +

        +

        +

        allow_nonref

        +
        +    $json = $json->allow_nonref([$enable])
        +
        +    $enabled = $json->get_allow_nonref
        +

        If $enable is true (or missing), then the encode method can convert a +non-reference into its corresponding string, number or null JSON value, +which is an extension to RFC4627. Likewise, decode will accept those JSON +values instead of croaking.

        +

        If $enable is false, then the encode method will croak if it isn't +passed an arrayref or hashref, as JSON texts must either be an object +or array. Likewise, decode will croak if given something that is not a +JSON object or array.

        +
        +   GT::JSON->new->allow_nonref->encode ("Hello, World!")
        +   => "Hello, World!"
        +

        +

        +

        allow_unknown

        +
        +    $json = $json->allow_unknown ([$enable])
        +
        +    $enabled = $json->get_allow_unknown
        +

        If $enable is true (or missing), then ``encode'' will *not* throw an +exception when it encounters values it cannot represent in JSON (for +example, filehandles) but instead will encode a JSON ``null'' value. +Note that blessed objects are not included here and are handled +separately by c<allow_nonref>.

        +

        If $enable is false (the default), then ``encode'' will throw an +exception when it encounters anything it cannot encode as JSON.

        +

        This option does not affect ``decode'' in any way, and it is +recommended to leave it off unless you know your communications +partner.

        +

        +

        +

        allow_blessed

        +
        +    $json = $json->allow_blessed([$enable])
        +
        +    $enabled = $json->get_allow_blessed
        +

        If $enable is true (or missing), then the encode method will not +barf when it encounters a blessed reference. Instead, the value of the +convert_blessed option will decide whether null (convert_blessed +disabled or no TO_JSON method found) or a representation of the +object (convert_blessed enabled and TO_JSON method found) is being +encoded. Has no effect on decode.

        +

        If $enable is false (the default), then encode will throw an +exception when it encounters a blessed object.

        +

        +

        +

        convert_blessed

        +
        +    $json = $json->convert_blessed([$enable])
        +
        +    $enabled = $json->get_convert_blessed
        +

        If $enable is true (or missing), then encode, upon encountering a +blessed object, will check for the availability of the TO_JSON method +on the object's class. If found, it will be called in scalar context +and the resulting scalar will be encoded instead of the object. If no +TO_JSON method is found, the value of allow_blessed will decide what +to do.

        +

        The TO_JSON method may safely call die if it wants. If TO_JSON +returns other blessed objects, those will be handled in the same +way. TO_JSON must take care of not causing an endless recursion cycle +(== crash) in this case. The name of TO_JSON was chosen because other +methods called by the Perl core (== not by the user of the object) are +usually in upper case letters and to avoid collisions with the to_json +function or method.

        +

        This setting does not yet influence decode in any way.

        +

        If $enable is false, then the allow_blessed setting will decide what +to do when a blessed object is found.

        +
        +
        convert_blessed_universally mode + +
        +

        If use GT::JSON with -convert_blessed_universally, the UNIVERSAL::TO_JSON +subroutine is defined as the below code:

        +
        +
        +
        +   *UNIVERSAL::TO_JSON = sub {
        +       my $b_obj = B::svref_2object( $_[0] );
        +       return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
        +               : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
        +               : undef
        +               ;
        +   }
        +
        +
        +

        This will cause that encode method converts simple blessed objects into +JSON objects as non-blessed object.

        +
        +
        +
        +   JSON -convert_blessed_universally;
        +   $json->allow_blessed->convert_blessed->encode( $blessed_object )
        +
        +
        +

        This feature is experimental and may be removed in the future.

        +
        + +
        +

        +

        +

        filter_json_object

        +
        +    $json = $json->filter_json_object([$coderef])
        +

        When $coderef is specified, it will be called from decode each +time it decodes a JSON object. The only argument passed to the coderef +is a reference to the newly-created hash. If the code references returns +a single scalar (which need not be a reference), this value +(i.e. a copy of that scalar to avoid aliasing) is inserted into the +deserialised data structure. If it returns an empty list +(NOTE: not undef, which is a valid scalar), the original deserialised +hash will be inserted. This setting can slow down decoding considerably.

        +

        When $coderef is omitted or undefined, any existing callback will +be removed and decode will not change the deserialised hash in any +way.

        +

        Example, convert all JSON objects into the integer 5:

        +
        +   my $js = GT::JSON->new->filter_json_object (sub { 5 });
        +   # returns [5]
        +   $js->decode ('[{}]'); # the given subroutine takes a hash reference.
        +   # throw an exception because allow_nonref is not enabled
        +   # so a lone 5 is not allowed.
        +   $js->decode ('{"a":1, "b":2}');
        +

        +

        +

        filter_json_single_key_object

        +
        +    $json = $json->filter_json_single_key_object($key [=> $coderef])
        +

        Works remotely similar to filter_json_object, but is only called for +JSON objects having a single key named $key.

        +

        This $coderef is called before the one specified via +filter_json_object, if any. It gets passed the single value in the JSON +object. If it returns a single value, it will be inserted into the data +structure. If it returns nothing (not even undef but the empty list), +the callback from filter_json_object will be called next, as if no +single-key callback were specified.

        +

        If $coderef is omitted or undefined, the corresponding callback will be +disabled. There can only ever be one callback for a given key.

        +

        As this callback gets called less often then the filter_json_object +one, decoding speed will not usually suffer as much. Therefore, single-key +objects make excellent targets to serialise Perl objects into, especially +as single-key JSON objects are as close to the type-tagged value concept +as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not +support this in any way, so you need to make sure your data never looks +like a serialised Perl hash.

        +

        Typical names for the single object key are __class_whatever__, or +$__dollars_are_rarely_used__$ or }ugly_brace_placement, or even +things like __class_md5sum(classname)__, to reduce the risk of clashing +with real hashes.

        +

        Example, decode JSON objects of the form { "__widget__" => <id> } +into the corresponding $WIDGET{<id>} object:

        +
        +   # return whatever is in $WIDGET{5}:
        +   GT::JSON
        +      ->new
        +      ->filter_json_single_key_object (__widget__ => sub {
        +            $WIDGET{ $_[0] }
        +         })
        +      ->decode ('{"__widget__": 5')
        +
        +   # this can be used with a TO_JSON method in some "widget" class
        +   # for serialisation to json:
        +   sub WidgetBase::TO_JSON {
        +      my ($self) = @_;
        +
        +      unless ($self->{id}) {
        +         $self->{id} = ..get..some..id..;
        +         $WIDGET{$self->{id}} = $self;
        +      }
        +
        +      { __widget__ => $self->{id} }
        +   }
        +

        +

        +

        shrink

        +
        +    $json = $json->shrink([$enable])
        +
        +    $enabled = $json->get_shrink
        +

        With JSON::XS, this flag resizes strings generated by either +encode or decode to their minimum size possible. This can save +memory when your JSON texts are either very very long or you have many +short strings. It will also try to downgrade any strings to octet-form +if possible: perl stores strings internally either in an encoding called +UTF-X or in octet-form. The latter cannot store everything but uses less +space in general (and some buggy Perl or C code might even rely on that +internal representation being used).

        +

        With GT::JSON::PP, it is noop about resizing strings but tries +utf8::downgrade to the returned string by encode. See to the utf8 manpage.

        +

        See to OBJECT-ORIENTED INTERFACE in the JSON::XS manpage and METHODS in the GT::JSON::PP manpage.

        +

        +

        +

        max_depth

        +
        +    $json = $json->max_depth([$maximum_nesting_depth])
        +
        +    $max_depth = $json->get_max_depth
        +

        Sets the maximum nesting level (default 512) accepted while encoding +or decoding. If a higher nesting level is detected in JSON text or a Perl +data structure, then the encoder and decoder will stop and croak at that +point.

        +

        Nesting level is defined by number of hash- or arrayrefs that the encoder +needs to traverse to reach a given point or the number of { or [ +characters without their matching closing parenthesis crossed to reach a +given character in a string.

        +

        If no argument is given, the highest possible setting will be used, which +is rarely useful.

        +

        Note that nesting is implemented by recursion in C. The default value has +been chosen to be as large as typical operating systems allow without +crashing. (JSON::XS)

        +

        With GT::JSON::PP as the backend, when a large value (100 or more) was set and +it de/encodes a deep nested object/text, it may raise a warning +'Deep recursion on subroutin' at the perl runtime phase.

        +

        See SECURITY CONSIDERATIONS in the JSON::XS manpage for more info on why this is useful.

        +

        +

        +

        max_size

        +
        +    $json = $json->max_size([$maximum_string_size])
        +
        +    $max_size = $json->get_max_size
        +

        Set the maximum length a JSON text may have (in bytes) where decoding is +being attempted. The default is 0, meaning no limit. When decode +is called on a string that is longer then this many bytes, it will not +attempt to decode the string but throw an exception. This setting has no +effect on encode (yet).

        +

        If no argument is given, the limit check will be deactivated (same as when +0 is specified).

        +

        See SECURITY CONSIDERATIONS in the JSON::XS manpage, below, for more info on why this is useful.

        +

        +

        +

        encode

        +
        +    $json_text = $json->encode($perl_scalar)
        +

        Converts the given Perl data structure (a simple scalar or a reference +to a hash or array) to its JSON representation. Simple scalars will be +converted into JSON string or number sequences, while references to arrays +become JSON arrays and references to hashes become JSON objects. Undefined +Perl values (e.g. undef) become JSON null values. +References to the integers 0 and 1 are converted into true and false.

        +

        +

        +

        decode

        +
        +    $perl_scalar = $json->decode($json_text)
        +

        The opposite of encode: expects a JSON text and tries to parse it, +returning the resulting simple scalar or reference. Croaks on error.

        +

        JSON numbers and strings become simple Perl scalars. JSON arrays become +Perl arrayrefs and JSON objects become Perl hashrefs. true becomes +1 (JSON::true), false becomes 0 (JSON::false) and +null becomes undef.

        +

        +

        +

        decode_prefix

        +
        +    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
        +

        This works like the decode method, but instead of raising an exception +when there is trailing garbage after the first JSON object, it will +silently stop parsing there and return the number of characters consumed +so far.

        +
        +   GT::JSON->new->decode_prefix ("[1] the tail")
        +   => ([], 3)
        +

        See to OBJECT-ORIENTED INTERFACE in the JSON::XS manpage

        +

        +

        +

        property

        +
        +    $boolean = $json->property($property_name)
        +

        Returns a boolean value about above some properties.

        +

        The available properties are ascii, latin1, utf8, +indent,space_before, space_after, relaxed, canonical, +allow_nonref, allow_unknown, allow_blessed, convert_blessed, +shrink, max_depth and max_size.

        +
        +   $boolean = $json->property('utf8');
        +    => 0
        +   $json->utf8;
        +   $boolean = $json->property('utf8');
        +    => 1
        +

        Sets the propery with a given boolean value.

        +
        +    $json = $json->property($property_name => $boolean);
        +

        With no argumnt, it returns all the above properties as a hash reference.

        +
        +    $flag_hashref = $json->property();
        +

        +

        +
        +

        INCREMENTAL PARSING

        +

        In JSON::XS 2.2, incremental parsing feature of JSON texts was implemented. +Please check to INCREMENTAL PARSING in the JSON::XS manpage.

        +
        +
        [void, scalar or list context] = $json->incr_parse ([$string]) + +
        +

        This is the central parsing function. It can both append new text and +extract objects from the stream accumulated so far (both of these +functions are optional).

        +
        +
        +

        If $string is given, then this string is appended to the already +existing JSON fragment stored in the $json object.

        +
        +
        +

        After that, if the function is called in void context, it will simply +return without doing anything further. This can be used to add more text +in as many chunks as you want.

        +
        +
        +

        If the method is called in scalar context, then it will try to extract +exactly one JSON object. If that is successful, it will return this +object, otherwise it will return undef. If there is a parse error, +this method will croak just as decode would do (one can then use +incr_skip to skip the errornous part). This is the most common way of +using the method.

        +
        +
        +

        And finally, in list context, it will try to extract as many objects +from the stream as it can find and return them, or the empty list +otherwise. For this to work, there must be no separators between the JSON +objects or arrays, instead they must be concatenated back-to-back. If +an error occurs, an exception will be raised as in the scalar context +case. Note that in this case, any previously-parsed JSON texts will be +lost.

        +
        + +
        $lvalue_string = $json->incr_text + +
        +

        This method returns the currently stored JSON fragment as an lvalue, that +is, you can manipulate it. This only works when a preceding call to +incr_parse in scalar context successfully returned an object. Under +all other circumstances you must not call this function (I mean it. +although in simple tests it might actually work, it will fail under +real world conditions). As a special exception, you can also call this +method before having parsed anything.

        +
        +
        +

        This function is useful in two cases: a) finding the trailing text after a +JSON object or b) parsing multiple JSON objects separated by non-JSON text +(such as commas).

        +
        +
        +

        In Perl 5.005, lvalue attribute is not available. +You must write codes like the below:

        +
        +
        +
        +    $string = $json->incr_text;
        +    $string =~ s/\s*,\s*//;
        +    $json->incr_text( $string );
        +
        + +
        $json->incr_skip + +
        +

        This will reset the state of the incremental parser and will remove the +parsed text from the input buffer. This is useful after incr_parse +died, in which case the input buffer and incremental parser state is left +unchanged, to skip the text parsed so far and to reset the parse state.

        +
        + +
        $json->incr_reset + +
        +

        This completely resets the incremental parser, that is, after this call, +it will be as if the parser had never parsed anything.

        +
        +
        +

        This is useful if you want ot repeatedly parse JSON objects and want to +ignore any trailing data, which means you have to reset the parser after +each successful decode.

        +
        + +
        +

        +

        +
        +

        GT::JSON::PP SUPPORT METHODS

        +

        The below methods are GT::JSON::PP own methods, so when GT::JSON works +with GT::JSON::PP (i.e. the created object is a GT::JSON::PP object), available. +See to GT::JSON::PP OWN METHODS in the GT::JSON::PP manpage in detail.

        +

        If you use GT::JSON with additonal -support_by_pp, some methods +are available even with JSON::XS. See to USE PP FEATURES EVEN THOUGH XS BACKEND.

        +
        +   BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
        +
        +   use GT::JSON -support_by_pp;
        +
        +   my $json = new GT::JSON;
        +   $json->allow_nonref->escape_slash->encode("/");
        +
        +   # functional interfaces too.
        +   print to_json(["/"], {escape_slash => 1});
        +   print from_json('["foo"]', {utf8 => 1});
        +

        If you do not want to all functions but -support_by_pp, +use -no_export.

        +
        +   use GT::JSON -support_by_pp, -no_export;
        +   # functional interfaces are not exported.
        +

        +

        +

        allow_singlequote

        +
        +    $json = $json->allow_singlequote([$enable])
        +

        If $enable is true (or missing), then decode will accept +any JSON strings quoted by single quotations that are invalid JSON +format.

        +
        +    $json->allow_singlequote->decode({"foo":'bar'});
        +    $json->allow_singlequote->decode({'foo':"bar"});
        +    $json->allow_singlequote->decode({'foo':'bar'});
        +

        As same as the relaxed option, this option may be used to parse +application-specific files written by humans.

        +

        +

        +

        allow_barekey

        +
        +    $json = $json->allow_barekey([$enable])
        +

        If $enable is true (or missing), then decode will accept +bare keys of JSON object that are invalid JSON format.

        +

        As same as the relaxed option, this option may be used to parse +application-specific files written by humans.

        +
        +    $json->allow_barekey->decode('{foo:"bar"}');
        +

        +

        +

        allow_bignum

        +
        +    $json = $json->allow_bignum([$enable])
        +

        If $enable is true (or missing), then decode will convert +the big integer Perl cannot handle as integer into a the Math::BigInt manpage +object and convert a floating number (any) into a the Math::BigFloat manpage.

        +

        On the contary, encode converts Math::BigInt objects and Math::BigFloat +objects into JSON numbers with allow_blessed enable.

        +
        +   $json->allow_nonref->allow_blessed->allow_bignum;
        +   $bigfloat = $json->decode('2.000000000000000000000000001');
        +   print $json->encode($bigfloat);
        +   # => 2.000000000000000000000000001
        +

        See to MAPPING aboout the conversion of JSON number.

        +

        +

        +

        loose

        +
        +    $json = $json->loose([$enable])
        +

        The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings +and the module doesn't allow to decode to these (except for \x2f). +If $enable is true (or missing), then decode will accept these +unescaped strings.

        +
        +    $json->loose->decode(qq|["abc
        +                                   def"]|);
        +

        See to GT::JSON::PP OWN METHODS in the GT::JSON::PP manpage.

        +

        +

        +

        escape_slash

        +
        +    $json = $json->escape_slash([$enable])
        +

        According to JSON Grammar, slash (U+002F) is escaped. But by default +JSON backend modules encode strings without escaping slash.

        +

        If $enable is true (or missing), then encode will escape slashes.

        +

        +

        +

        indent_length

        +
        +    $json = $json->indent_length($length)
        +

        With JSON::XS, The indent space length is 3 and cannot be changed. +With GT::JSON::PP, it sets the indent space length with the given $length. +The default is 3. The acceptable range is 0 to 15.

        +

        +

        +

        sort_by

        +
        +    $json = $json->sort_by($function_name)
        +    $json = $json->sort_by($subroutine_ref)
        +

        If $function_name or $subroutine_ref are set, its sort routine are used.

        +
        +   $js = $pc->sort_by(sub { $GT::JSON::PP::a cmp $GT::JSON::PP::b })->encode($obj);
        +   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
        +
        +   $js = $pc->sort_by('own_sort')->encode($obj);
        +   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
        +
        +   sub GT::JSON::PP::own_sort { $GT::JSON::PP::a cmp $GT::JSON::PP::b }
        +

        As the sorting routine runs in the GT::JSON::PP scope, the given +subroutine name and the special variables $a, $b will begin +with 'GT::JSON::PP::'.

        +

        If $integer is set, then the effect is same as canonical on.

        +

        See to GT::JSON::PP OWN METHODS in the GT::JSON::PP manpage.

        +

        +

        +
        +

        MAPPING

        +

        This section is copied from JSON::XS and modified to GT::JSON. +JSON::XS and GT::JSON::PP mapping mechanisms are almost equivalent.

        +

        See to MAPPING in the JSON::XS manpage.

        +

        +

        +

        JSON -> PERL

        +
        +
        object + +
        +

        A JSON object becomes a reference to a hash in Perl. No ordering of object +keys is preserved (JSON does not preserver object key ordering itself).

        +
        + +
        array + +
        +

        A JSON array becomes a reference to an array in Perl.

        +
        + +
        string + +
        +

        A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON +are represented by the same codepoints in the Perl string, so no manual +decoding is necessary.

        +
        + +
        number + +
        +

        A JSON number becomes either an integer, numeric (floating point) or +string scalar in perl, depending on its range and any fractional parts. On +the Perl level, there is no difference between those as Perl handles all +the conversion details, but an integer may take slightly less memory and +might represent more values exactly than floating point numbers.

        +
        +
        +

        If the number consists of digits only, GT::JSON will try to represent +it as an integer value. If that fails, it will try to represent it as +a numeric (floating point) value if that is possible without loss of +precision. Otherwise it will preserve the number as a string value (in +which case you lose roundtripping ability, as the JSON number will be +re-encoded toa JSON string).

        +
        +
        +

        Numbers containing a fractional or exponential part will always be +represented as numeric (floating point) values, possibly at a loss of +precision (in which case you might lose perfect roundtripping ability, but +the JSON number will still be re-encoded as a JSON number).

        +
        +
        +

        If the backend is GT::JSON::PP and allow_bignum is enable, the big integers +and the numeric can be optionally converted into the Math::BigInt manpage and +the Math::BigFloat manpage objects.

        +
        + +
        true, false + +
        +

        These JSON atoms become GT::JSON::true and GT::JSON::false, +respectively. They are overloaded to act almost exactly like the numbers +1 and 0. You can check wether a scalar is a JSON boolean by using +the GT::JSON::is_bool function.

        +
        +
        +

        If GT::JSON::true and GT::JSON::false are used as strings or compared as strings, +they represent as true and false respectively.

        +
        +
        +
        +   print GT::JSON::true . "\n";
        +    => true
        +   print GT::JSON::true + 1;
        +    => 1
        +
        +
        +
        +   ok(GT::JSON::true eq 'true');
        +   ok(GT::JSON::true eq  '1');
        +   ok(GT::JSON::true == 1);
        +
        +
        +

        GT::JSON will install these missing overloading features to the backend modules.

        +
        + +
        null + +
        +

        A JSON null atom becomes undef in Perl.

        +
        +
        +

        GT::JSON::null returns unddef.

        +
        + +
        +

        +

        +

        PERL -> JSON

        +

        The mapping from Perl to JSON is slightly more difficult, as Perl is a +truly typeless language, so we can only guess which JSON type is meant by +a Perl value.

        +
        +
        hash references + +
        +

        Perl hash references become JSON objects. As there is no inherent ordering +in hash keys (or JSON objects), they will usually be encoded in a +pseudo-random order that can change between runs of the same program but +stays generally the same within a single run of a program. GT::JSON +optionally sort the hash keys (determined by the canonical flag), so +the same datastructure will serialise to the same JSON text (given same +settings and version of JSON::XS), but this incurs a runtime overhead +and is only rarely useful, e.g. when you want to compare some JSON text +against another for equality.

        +
        +
        +

        In future, the ordered object feature will be added to GT::JSON::PP using tie mechanism.

        +
        + +
        array references + +
        +

        Perl array references become JSON arrays.

        +
        + +
        other references + +
        +

        Other unblessed references are generally not allowed and will cause an +exception to be thrown, except for references to the integers 0 and +1, which get turned into false and true atoms in JSON. You can +also use GT::JSON::false and GT::JSON::true to improve readability.

        +
        +
        +
        +   to_json [\0,GT::JSON::true]      # yields [false,true]
        +
        + +
        GT::JSON::true, GT::JSON::false, GT::JSON::null + +
        +

        These special values become JSON true and JSON false values, +respectively. You can also use \1 and \0 directly if you want.

        +
        +
        +

        GT::JSON::null returns undef.

        +
        + +
        blessed objects + +
        +

        Blessed objects are not directly representable in JSON. See the +allow_blessed and convert_blessed methods on various options on +how to deal with this: basically, you can choose between throwing an +exception, encoding the reference as if it weren't blessed, or provide +your own serialiser method.

        +
        +
        +

        With convert_blessed_universally mode, encode converts blessed +hash references or blessed array references (contains other blessed references) +into JSON members and arrays.

        +
        +
        +
        +   use GT::JSON -convert_blessed_universally;
        +   GT::JSON->new->allow_blessed->convert_blessed->encode( $blessed_object );
        +
        +
        +

        See to the convert_blessed manpage.

        +
        + +
        simple scalars + +
        +

        Simple Perl scalars (any scalar that is not a reference) are the most +difficult objects to encode: JSON::XS and GT::JSON::PP will encode undefined scalars as +JSON null values, scalars that have last been used in a string context +before encoding as JSON strings, and anything else as number value:

        +
        +
        +
        +   # dump as number
        +   encode_json [2]                      # yields [2]
        +   encode_json [-3.0e17]                # yields [-3e+17]
        +   my $value = 5; encode_json [$value]  # yields [5]
        +
        +
        +
        +   # used as string, so dump as string
        +   print $value;
        +   encode_json [$value]                 # yields ["5"]
        +
        +
        +
        +   # undef becomes null
        +   encode_json [undef]                  # yields [null]
        +
        +
        +

        You can force the type to be a string by stringifying it:

        +
        +
        +
        +   my $x = 3.1; # some variable containing a number
        +   "$x";        # stringified
        +   $x .= "";    # another, more awkward way to stringify
        +   print $x;    # perl does it for you, too, quite often
        +
        +
        +

        You can force the type to be a number by numifying it:

        +
        +
        +
        +   my $x = "3"; # some variable containing a string
        +   $x += 0;     # numify it, ensuring it will be dumped as a number
        +   $x *= 1;     # same thing, the choise is yours.
        +
        +
        +

        You can not currently force the type in other, less obscure, ways.

        +
        + +
        Big Number + +
        +

        If the backend is GT::JSON::PP and allow_bignum is enable, +encode converts Math::BigInt objects and Math::BigFloat +objects into JSON numbers.

        +
        + +
        +

        +

        +
        +

        JSON and ECMAscript

        +

        See to JSON and ECMAscript in the JSON::XS manpage.

        +

        +

        +
        +

        JSON and YAML

        +

        JSON is not a subset of YAML. +See to JSON and YAML in the JSON::XS manpage.

        +

        +

        +
        +

        BACKEND MODULE DECISION

        +

        When you use GT::JSON, GT::JSON tries to use JSON::XS. If this call failed, it will +uses GT::JSON::PP. The required JSON::XS version is 2.2 or later.

        +

        The GT::JSON constructor method returns an object inherited from the backend module, +and JSON::XS object is a blessed scaler reference while GT::JSON::PP is a blessed hash +reference.

        +

        So, your program should not depend on the backend module, especially +returned objects should not be modified.

        +
        + my $json = GT::JSON->new; # XS or PP?
        + $json->{stash} = 'this is xs object'; # this code may raise an error!
        +

        To check the backend module, there are some methods - backend, is_pp and is_xs.

        +
        +  GT::JSON->backend; # 'JSON::XS' or 'GT::JSON::PP'
        +
        +  GT::JSON->backend->is_pp: # 0 or 1
        +
        +  GT::JSON->backend->is_xs: # 1 or 0
        +
        +  $json->is_xs; # 1 or 0
        +
        +  $json->is_pp; # 0 or 1
        +

        If you set an enviornment variable PERL_JSON_BACKEND, The calling action will be changed.

        +
        +
        PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'GT::JSON::PP' + +
        +

        Always use GT::JSON::PP

        +
        + +
        PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,GT::JSON::PP' + +
        +

        (The default) Use compiled JSON::XS if it is properly compiled & installed, +otherwise use GT::JSON::PP.

        +
        + +
        PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS' + +
        +

        Always use compiled JSON::XS, die if it isn't properly compiled & installed.

        +
        + +
        +

        These ideas come from the DBI::PurePerl manpage mechanism.

        +

        example:

        +
        + BEGIN { $ENV{PERL_JSON_BACKEND} = 'GT::JSON::PP' }
        + use GT::JSON; # always uses GT::JSON::PP
        +

        In future, it may be able to specify another module.

        +

        +

        +
        +

        USE PP FEATURES EVEN THOUGH XS BACKEND

        +

        Many methods are available with either JSON::XS or GT::JSON::PP and +when the backend module is JSON::XS, if any GT::JSON::PP specific (i.e. JSON::XS unspported) +method is called, it will warn and be noop.

        +

        But If you use GT::JSON passing the optional string -support_by_pp, +it makes a part of those unupported methods available. +This feature is achieved by using GT::JSON::PP in de/encode.

        +
        +   BEING { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS
        +   use GT::JSON -support_by_pp;
        +   my $json = new GT::JSON;
        +   $json->allow_nonref->escape_slash->encode("/");
        +

        At this time, the returned object is a GT::JSON::Backend::XS::Supportable +object (re-blessed XS object), and by checking JSON::XS unsupported flags +in de/encoding, can support some unsupported methods - loose, allow_bignum, +allow_barekey, allow_singlequote, escape_slash, as_nonblessed +and indent_length.

        +

        When any unsupported methods are not enable, XS de/encode will be +used as is. The switch is achieved by changing the symbolic tables.

        +

        -support_by_pp is effective only when the backend module is GT::JSON::XS +and it makes the de/encoding speed down a bit.

        +

        See to GT::JSON::PP SUPPORT METHODS.

        +

        +

        +
        +

        TODO

        +
        +
        example programs + +
        +

        +

        +
        +

        THREADS

        +

        No test with GT::JSON::PP. If with JSON::XS, See to THREADS in the JSON::XS manpage.

        +

        +

        +
        +

        BUGS

        +

        Please report bugs relevant to GT::JSON to <makamaka[at]cpan.org>.

        +

        +

        +
        +

        SEE ALSO

        +

        Most of the document is copied and modified from JSON::XS doc.

        +

        the JSON::XS manpage, the GT::JSON::PP manpage

        +

        RFC4627(http://www.ietf.org/rfc/rfc4627.txt)

        +

        +

        +
        +

        AUTHOR

        +

        Makamaka Hannyaharamitu, <makamaka[at]cpan.org>

        +

        JSON::XS was written by Marc Lehmann <schmorp[at]schmorp.de>

        +

        The relese of this new version owes to the courtesy of Marc Lehmann.

        +

        +

        +
        +

        COPYRIGHT AND LICENSE

        +

        Copyright 2005-2008 by Makamaka Hannyaharamitu

        +

        This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP.html new file mode 100644 index 0000000..f9ea064 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP.html @@ -0,0 +1,966 @@ + + + + +GT::JSON::PP - JSON::XS compatible pure-Perl module. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::JSON::PP - JSON::XS compatible pure-Perl module.

        +

        +

        +
        +

        SYNOPSIS

        +
        + use GT::JSON::PP;
        +
        + # exported functions, they croak on error
        + # and expect/generate UTF-8
        +
        + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
        + $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
        +
        + # OO-interface
        +
        + $coder = GT::JSON::PP->new->ascii->pretty->allow_nonref;
        + $pretty_printed_unencoded = $coder->encode ($perl_scalar);
        + $perl_scalar = $coder->decode ($unicode_json_text);
        +
        + # Note that GT::JSON version 2.0 and above will automatically use
        + # JSON::XS or GT::JSON::PP, so you should be able to just:
        + 
        + use GT::JSON;
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is the JSON::XS manpage compatible pure Perl module. +(Perl 5.8 or later is recommended)

        +

        JSON::XS is the fastest and most proper JSON module on CPAN. +It is written by Marc Lehmann in C, so must be compiled and +installed in the used environment.

        +

        GT::JSON::PP is a pure-Perl module and has compatibility to JSON::XS.

        +

        +

        +

        FEATURES

        + +

        +

        +
        +

        FUNCTIONS

        +

        Basically, check to the GT::JSON manpage or the JSON::XS manpage.

        +

        +

        +

        encode_json

        +
        +    $json_text = encode_json $perl_scalar
        +

        +

        +

        decode_json

        +
        +    $perl_scalar = decode_json $json_text
        +

        +

        +

        GT::JSON::PP::true

        +

        Returns JSON true value which is blessed object. +It isa GT::JSON::PP::Boolean object.

        +

        +

        +

        GT::JSON::PP::false

        +

        Returns JSON false value which is blessed object. +It isa GT::JSON::PP::Boolean object.

        +

        +

        +

        GT::JSON::PP::null

        +

        Returns undef.

        +

        +

        +
        +

        METHODS

        +

        Basically, check to the GT::JSON manpage or the JSON::XS manpage.

        +

        +

        +

        new

        +
        +    $json = new GT::JSON::PP
        +

        Rturns a new GT::JSON::PP object that can be used to de/encode JSON +strings.

        +

        +

        +

        ascii

        +
        +    $json = $json->ascii([$enable])
        +    
        +    $enabled = $json->get_ascii
        +

        If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. +(See to OBJECT-ORIENTED INTERFACE in the JSON::XS manpage).

        +

        In Perl 5.005, there is no character having high value (more than 255). +See to UNICODE HANDLING ON PERLS.

        +

        If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format.

        +
        +  GT::JSON::PP->new->ascii(1)->encode([chr 0x10401])
        +  => ["\ud801\udc01"]
        +

        +

        +

        latin1

        +
        +    $json = $json->latin1([$enable])
        +    
        +    $enabled = $json->get_latin1
        +

        If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.

        +

        If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags.

        +
        +  JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
        +  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
        +

        See to UNICODE HANDLING ON PERLS.

        +

        +

        +

        utf8

        +
        +    $json = $json->utf8([$enable])
        +    
        +    $enabled = $json->get_utf8
        +

        If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O.

        +

        (In Perl 5.005, any character outside the range 0..255 does not exist. +See to UNICODE HANDLING ON PERLS.)

        +

        In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627.

        +

        If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.

        +

        Example, output UTF-16BE-encoded JSON:

        +
        +  use Encode;
        +  $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
        +

        Example, decode UTF-32LE-encoded JSON:

        +
        +  use Encode;
        +  $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
        +

        +

        +

        pretty

        +
        +    $json = $json->pretty([$enable])
        +

        This enables (or disables) all of the indent, space_before and +space_after flags in one call to generate the most readable +(or most compact) form possible.

        +

        +

        +

        indent

        +
        +    $json = $json->indent([$enable])
        +    
        +    $enabled = $json->get_indent
        +

        The default indent space lenght is three. +You can use indent_length to change the length.

        +

        +

        +

        space_before

        +
        +    $json = $json->space_before([$enable])
        +    
        +    $enabled = $json->get_space_before
        +

        +

        +

        space_after

        +
        +    $json = $json->space_after([$enable])
        +    
        +    $enabled = $json->get_space_after
        +

        +

        +

        relaxed

        +
        +    $json = $json->relaxed([$enable])
        +    
        +    $enabled = $json->get_relaxed
        +

        +

        +

        canonical

        +
        +    $json = $json->canonical([$enable])
        +    
        +    $enabled = $json->get_canonical
        +

        If you want your own sorting routine, you can give a code referece +or a subroutine name to sort_by. See to GT::JSON::PP OWN METHODS.

        +

        +

        +

        allow_nonref

        +
        +    $json = $json->allow_nonref([$enable])
        +    
        +    $enabled = $json->get_allow_nonref
        +

        +

        +

        allow_unknown

        +
        +    $json = $json->allow_unknown ([$enable])
        +    
        +    $enabled = $json->get_allow_unknown
        +

        +

        +

        allow_blessed

        +
        +    $json = $json->allow_blessed([$enable])
        +    
        +    $enabled = $json->get_allow_blessed
        +

        +

        +

        convert_blessed

        +
        +    $json = $json->convert_blessed([$enable])
        +    
        +    $enabled = $json->get_convert_blessed
        +

        +

        +

        filter_json_object

        +
        +    $json = $json->filter_json_object([$coderef])
        +

        +

        +

        filter_json_single_key_object

        +
        +    $json = $json->filter_json_single_key_object($key [=> $coderef])
        +

        +

        +

        shrink

        +
        +    $json = $json->shrink([$enable])
        +    
        +    $enabled = $json->get_shrink
        +

        In JSON::XS, this flag resizes strings generated by either +encode or decode to their minimum size possible. +It will also try to downgrade any strings to octet-form if possible.

        +

        In GT::JSON::PP, it is noop about resizing strings but tries +utf8::downgrade to the returned string by encode. +See to the utf8 manpage.

        +

        See to OBJECT-ORIENTED INTERFACE in the JSON::XS manpage

        +

        +

        +

        max_depth

        +
        +    $json = $json->max_depth([$maximum_nesting_depth])
        +    
        +    $max_depth = $json->get_max_depth
        +

        Sets the maximum nesting level (default 512) accepted while encoding +or decoding. If a higher nesting level is detected in JSON text or a Perl +data structure, then the encoder and decoder will stop and croak at that +point.

        +

        Nesting level is defined by number of hash- or arrayrefs that the encoder +needs to traverse to reach a given point or the number of { or [ +characters without their matching closing parenthesis crossed to reach a +given character in a string.

        +

        If no argument is given, the highest possible setting will be used, which +is rarely useful.

        +

        See SSECURITY CONSIDERATIONS in the JSON::XS manpage for more info on why this is useful.

        +

        When a large value (100 or more) was set and it de/encodes a deep nested object/text, +it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.

        +

        +

        +

        max_size

        +
        +    $json = $json->max_size([$maximum_string_size])
        +    
        +    $max_size = $json->get_max_size
        +

        Set the maximum length a JSON text may have (in bytes) where decoding is +being attempted. The default is 0, meaning no limit. When decode +is called on a string that is longer then this many bytes, it will not +attempt to decode the string but throw an exception. This setting has no +effect on encode (yet).

        +

        If no argument is given, the limit check will be deactivated (same as when +0 is specified).

        +

        See SSECURITY CONSIDERATIONS in the JSON::XS manpage for more info on why this is useful.

        +

        +

        +

        encode

        +
        +    $json_text = $json->encode($perl_scalar)
        +

        +

        +

        decode

        +
        +    $perl_scalar = $json->decode($json_text)
        +

        +

        +

        decode_prefix

        +
        +    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
        +

        +

        +
        +

        INCREMENTAL PARSING

        +

        In JSON::XS 2.2, incremental parsing feature of JSON +texts was experimentally implemented. +Please check to INCREMENTAL PARSING in the JSON::XS manpage.

        +
        +
        [void, scalar or list context] = $json->incr_parse ([$string]) + +
        +

        This is the central parsing function. It can both append new text and +extract objects from the stream accumulated so far (both of these +functions are optional).

        +
        +
        +

        If $string is given, then this string is appended to the already +existing JSON fragment stored in the $json object.

        +
        +
        +

        After that, if the function is called in void context, it will simply +return without doing anything further. This can be used to add more text +in as many chunks as you want.

        +
        +
        +

        If the method is called in scalar context, then it will try to extract +exactly one JSON object. If that is successful, it will return this +object, otherwise it will return undef. If there is a parse error, +this method will croak just as decode would do (one can then use +incr_skip to skip the errornous part). This is the most common way of +using the method.

        +
        +
        +

        And finally, in list context, it will try to extract as many objects +from the stream as it can find and return them, or the empty list +otherwise. For this to work, there must be no separators between the JSON +objects or arrays, instead they must be concatenated back-to-back. If +an error occurs, an exception will be raised as in the scalar context +case. Note that in this case, any previously-parsed JSON texts will be +lost.

        +
        + +
        $lvalue_string = $json->incr_text + +
        +

        This method returns the currently stored JSON fragment as an lvalue, that +is, you can manipulate it. This only works when a preceding call to +incr_parse in scalar context successfully returned an object. Under +all other circumstances you must not call this function (I mean it. +although in simple tests it might actually work, it will fail under +real world conditions). As a special exception, you can also call this +method before having parsed anything.

        +
        +
        +

        This function is useful in two cases: a) finding the trailing text after a +JSON object or b) parsing multiple JSON objects separated by non-JSON text +(such as commas).

        +
        +
        +

        In Perl 5.005, lvalue attribute is not available. +You must write codes like the below:

        +
        +
        +
        +    $string = $json->incr_text;
        +    $string =~ s/\s*,\s*//;
        +    $json->incr_text( $string );
        +
        + +
        $json->incr_skip + +
        +

        This will reset the state of the incremental parser and will remove the +parsed text from the input buffer. This is useful after incr_parse +died, in which case the input buffer and incremental parser state is left +unchanged, to skip the text parsed so far and to reset the parse state.

        +
        + +
        +

        +

        +
        +

        GT::JSON::PP OWN METHODS

        +

        +

        +

        allow_singlequote

        +
        +    $json = $json->allow_singlequote([$enable])
        +

        If $enable is true (or missing), then decode will accept +JSON strings quoted by single quotations that are invalid JSON +format.

        +
        +    $json->allow_singlequote->decode({"foo":'bar'});
        +    $json->allow_singlequote->decode({'foo':"bar"});
        +    $json->allow_singlequote->decode({'foo':'bar'});
        +

        As same as the relaxed option, this option may be used to parse +application-specific files written by humans.

        +

        +

        +

        allow_barekey

        +
        +    $json = $json->allow_barekey([$enable])
        +

        If $enable is true (or missing), then decode will accept +bare keys of JSON object that are invalid JSON format.

        +

        As same as the relaxed option, this option may be used to parse +application-specific files written by humans.

        +
        +    $json->allow_barekey->decode('{foo:"bar"}');
        +

        +

        +

        allow_bignum

        +
        +    $json = $json->allow_bignum([$enable])
        +

        If $enable is true (or missing), then decode will convert +the big integer Perl cannot handle as integer into a the Math::BigInt manpage +object and convert a floating number (any) into a the Math::BigFloat manpage.

        +

        On the contary, encode converts Math::BigInt objects and Math::BigFloat +objects into JSON numbers with allow_blessed enable.

        +
        +   $json->allow_nonref->allow_blessed->allow_bignum;
        +   $bigfloat = $json->decode('2.000000000000000000000000001');
        +   print $json->encode($bigfloat);
        +   # => 2.000000000000000000000000001
        +

        See to MAPPING in the JSON::XS manpage aboout the normal conversion of JSON number.

        +

        +

        +

        loose

        +
        +    $json = $json->loose([$enable])
        +

        The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings +and the module doesn't allow to decode to these (except for \x2f). +If $enable is true (or missing), then decode will accept these +unescaped strings.

        +
        +    $json->loose->decode(qq|["abc
        +                                   def"]|);
        +

        See SSECURITY CONSIDERATIONS in the JSON::XS manpage.

        +

        +

        +

        escape_slash

        +
        +    $json = $json->escape_slash([$enable])
        +

        According to JSON Grammar, slash (U+002F) is escaped. But default +GT::JSON::PP (as same as JSON::XS) encodes strings without escaping slash.

        +

        If $enable is true (or missing), then encode will escape slashes.

        +

        +

        +

        (OBSOLETED)as_nonblessed

        +
        +    $json = $json->as_nonblessed
        +

        (OBSOLETED) If $enable is true (or missing), then encode will convert +a blessed hash reference or a blessed array reference (contains +other blessed references) into JSON members and arrays.

        +

        This feature is effective only when allow_blessed is enable.

        +

        +

        +

        indent_length

        +
        +    $json = $json->indent_length($length)
        +

        JSON::XS indent space length is 3 and cannot be changed. +GT::JSON::PP set the indent space length with the given $length. +The default is 3. The acceptable range is 0 to 15.

        +

        +

        +

        sort_by

        +
        +    $json = $json->sort_by($function_name)
        +    $json = $json->sort_by($subroutine_ref)
        +

        If $function_name or $subroutine_ref are set, its sort routine are used +in encoding JSON objects.

        +
        +   $js = $pc->sort_by(sub { $GT::JSON::PP::a cmp $GT::JSON::PP::b })->encode($obj);
        +   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
        +
        +   $js = $pc->sort_by('own_sort')->encode($obj);
        +   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
        +
        +   sub GT::JSON::PP::own_sort { $GT::JSON::PP::a cmp $GT::JSON::PP::b }
        +

        As the sorting routine runs in the GT::JSON::PP scope, the given +subroutine name and the special variables $a, $b will begin +'GT::JSON::PP::'.

        +

        If $integer is set, then the effect is same as canonical on.

        +

        +

        +
        +

        INTERNAL

        +

        For developers.

        +
        +
        PP_encode_box + +
        +

        Returns

        +
        +
        +
        +        {
        +            depth        => $depth,
        +            indent_count => $indent_count,
        +        }
        +
        + +
        PP_decode_box + +
        +

        Returns

        +
        +
        +
        +        {
        +            text    => $text,
        +            at      => $at,
        +            ch      => $ch,
        +            len     => $len,
        +            depth   => $depth,
        +            encoding      => $encoding,
        +            is_valid_utf8 => $is_valid_utf8,
        +        };
        +
        + +
        +

        +

        +
        +

        MAPPING

        +

        See to MAPPING in the JSON::XS manpage.

        +

        +

        +
        +

        UNICODE HANDLING ON PERLS

        +

        If you do not know about Unicode on Perl well, +please check A FEW NOTES ON UNICODE AND PERL in the JSON::XS manpage.

        +

        +

        +

        Perl 5.8 and later

        +

        Perl can handle Unicode and the GT::JSON::PP de/encode methods also work properly.

        +
        +    $json->allow_nonref->encode(chr hex 3042);
        +    $json->allow_nonref->encode(chr hex 12345);
        +

        Reuturns "\u3042" and "\ud808\udf45" respectively.

        +
        +    $json->allow_nonref->decode('"\u3042"');
        +    $json->allow_nonref->decode('"\ud808\udf45"');
        +

        Returns UTF-8 encoded strings with UTF8 flag, regarded as U+3042 and U+12345.

        +

        Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in join was broken, +so GT::JSON::PP wraps the join with a subroutine. Thus GT::JSON::PP works slow in the versions.

        +

        +

        +

        Perl 5.6

        +

        Perl can handle Unicode and the GT::JSON::PP de/encode methods also work.

        +

        +

        +

        Perl 5.005

        +

        Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. +That means the unicode handling is not available.

        +

        In encoding,

        +
        +    $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
        +    $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
        +

        Returns B and E, as chr takes a value more than 255, it treats +as $value % 256, so the above codes are equivalent to :

        +
        +    $json->allow_nonref->encode(chr 66);
        +    $json->allow_nonref->encode(chr 69);
        +

        In decoding,

        +
        +    $json->decode('"\u00e3\u0081\u0082"');
        +

        The returned is a byte sequence 0xE3 0x81 0x82 for UTF-8 encoded +japanese character (HIRAGANA LETTER A). +And if it is represented in Unicode code point, U+3042.

        +

        Next,

        +
        +    $json->decode('"\u3042"');
        +

        We ordinary expect the returned value is a Unicode character U+3042. +But here is 5.005 world. This is 0xE3 0x81 0x82.

        +
        +    $json->decode('"\ud808\udf45"');
        +

        This is not a character U+12345 but bytes - 0xf0 0x92 0x8d 0x85.

        +

        +

        +
        +

        TODO

        +
        +
        speed + +
        memory saving + +
        +

        +

        +
        +

        SEE ALSO

        +

        Most of the document are copied and modified from JSON::XS doc.

        +

        the JSON::XS manpage

        +

        RFC4627 (http://www.ietf.org/rfc/rfc4627.txt)

        +

        +

        +
        +

        AUTHOR

        +

        Makamaka Hannyaharamitu, <makamaka[at]cpan.org>

        +

        +

        +
        +

        COPYRIGHT AND LICENSE

        +

        Copyright 2008 by Makamaka Hannyaharamitu

        +

        This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP/Boolean.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP/Boolean.html new file mode 100644 index 0000000..1210e28 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP/Boolean.html @@ -0,0 +1,304 @@ + + + + +GT::JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::JSON::PP::Boolean - dummy module providing JSON::PP::Boolean

        +

        +

        +
        +

        SYNOPSIS

        +
        + # do not "use" yourself
        +

        +

        +
        +

        DESCRIPTION

        +

        This module exists only to provide overload resolution for Storable and similar modules. See +the GT::JSON::PP manpage for more info about this class.

        +

        +

        +
        +

        AUTHOR

        +

        This idea is from the JSON::XS::Boolean manpage written by Marc Lehmann <schmorp[at]schmorp.de>

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP5005.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP5005.html new file mode 100644 index 0000000..0ca4df7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP5005.html @@ -0,0 +1,305 @@ + + + + +GT::JSON::PP5005 - Helper module in using GT::JSON::PP in Perl 5.005 + + + + + + + + + + +

        + + + + + +
        +

        +

        +
        +

        NAME

        +

        GT::JSON::PP5005 - Helper module in using GT::JSON::PP in Perl 5.005

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::JSON::PP calls internally.

        +

        +

        +
        +

        AUTHOR

        +

        Makamaka Hannyaharamitu, <makamaka[at]cpan.org>

        +

        +

        +
        +

        COPYRIGHT AND LICENSE

        +

        Copyright 2007-2008 by Makamaka Hannyaharamitu

        +

        This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP56.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP56.html new file mode 100644 index 0000000..16049ce --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP56.html @@ -0,0 +1,305 @@ + + + + +GT::JSON::PP56 - Helper module in using GT::JSON::PP in Perl 5.6 + + + + + + + + + + +

        + + + + + +
        +

        +

        +
        +

        NAME

        +

        GT::JSON::PP56 - Helper module in using GT::JSON::PP in Perl 5.6

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::JSON::PP calls internally.

        +

        +

        +
        +

        AUTHOR

        +

        Makamaka Hannyaharamitu, <makamaka[at]cpan.org>

        +

        +

        +
        +

        COPYRIGHT AND LICENSE

        +

        Copyright 2007-2008 by Makamaka Hannyaharamitu

        +

        This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP58.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP58.html new file mode 100644 index 0000000..8e7aa1f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/JSON/PP58.html @@ -0,0 +1,305 @@ + + + + +GT::JSON::PP58 - Helper module in using GT::JSON::PP in Perl 5.8 and lator + + + + + + + + + + +

        + + + + + +
        +

        +

        +
        +

        NAME

        +

        GT::JSON::PP58 - Helper module in using GT::JSON::PP in Perl 5.8 and lator

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::JSON::PP calls internally.

        +

        +

        +
        +

        AUTHOR

        +

        Makamaka Hannyaharamitu, <makamaka[at]cpan.org>

        +

        +

        +
        +

        COPYRIGHT AND LICENSE

        +

        Copyright 2008 by Makamaka Hannyaharamitu

        +

        This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Lock.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Lock.html new file mode 100644 index 0000000..575e803 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Lock.html @@ -0,0 +1,365 @@ + + + + +GT::Lock - a small autonomous locking module. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Lock - a small autonomous locking module.

        +

        +

        +

        SYNOPSIS

        +
        +    use GT::Lock qw/lock unlock LOCK_TRY LOCK_FORCE/;
        +
        +    # attempt to lock foobar for 10 seconds
        +    if (lock 'foobar', 10, LOCK_TRY) {
        +        # do some code that needs to be locked
        +        unlock 'foobar';
        +    }
        +    else {
        +        # oops out lock failed
        +        die "Lock failed: $GT::Lock::error\n";
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Lock is a very simple module to impliment autonomous named locking. Locking +can be used for many things but is most commonly used to lock files for IO to +them.

        +

        Nothing is exported by default. You may request the lock, unlock routines be +exported. You can also get the two constants for lock types exported: +LOCK_TRY and LOCK_FORCE.

        +

        +

        +

        lock - Lock a name.

        +
        +    lock NAME [, TIMOUT, TYPE, AGE ]
        +

        This method is used to create a lock. Its arguments are the name you wish to +give the lock, the timeout in seconds for the lock to happen, the type of lock, +and the maximum lock age (in seconds). The types are LOCK_FORCE and +LOCK_TRY. If LOCK_FORCE is given a lock always succeeds, e.g. if the +lock times out the lock is removed and your lock succeeds. Try attempts to get +the lock and returns false if the lock can not be had in the specified +TIMEOUT. If TIMEOUT is zero this method will attempt to lock forever. +TIMEOUT defaults to 10 seconds. The AGE parameter can be used to ensure +that stale locks are not preserved - if the lock already exists and is older +than AGE seconds, it will be removed before attempting to get the lock. +Omitting it uses the default value, undef, which does not attempt to remove +stale locks.

        +

        +

        +

        unlock - unlock a name.

        +
        +    unlock NAME
        +

        This method is used to unlock a name. It's argument is the name of the lock to +unlock. Returns true on success and false on errors and sets the error in +$GT::Lock::error.

        +

        +

        +
        +

        DEPENDANCIES

        +

        the GT::Lock manpage depends on the GT::TempFile manpage, bases, and constants.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5.html new file mode 100644 index 0000000..2811691 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5.html @@ -0,0 +1,477 @@ + + + + +GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm

        +

        +

        +
        +

        DISCLAIMER

        +

        Majority of this module's code is borrowed from Digest::Perl::MD5 (Version 1.8).

        +

        This is not an interface (like 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 Digest::MD5 instead of this module if it is available. +This module is only usefull for

        +
        +
        +
        +

        computers where you cannot install Digest::MD5 (e.g. lack of a C-Compiler)

        +
        + +
        +
        +

        encrypting only small amounts of data (less than one million bytes). I use it to +hash passwords.

        +
        + +
        +
        +

        educational purposes

        +
        + +
        +

        +

        +
        +

        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;
        +

        +

        +
        +

        DESCRIPTION

        +

        This modules has the same interface as the much faster 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 Digest::MD5 module is available it is used and if not you take +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 Digest::MD5 module.

        +

        +

        +
        +

        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
        +

        +

        +
        +

        LIMITATIONS

        +

        This implementation of the MD5 algorithm has some limitations:

        +
        +
        +
        +

        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.

        +
        + +
        +
        +

        You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should +use Digest::MD5 for those amounts of data anyway.

        +
        + +
        +

        +

        +
        +

        SEE ALSO

        +

        the Digest::MD5 manpage

        +

        md5(1)

        +

        RFC 1321

        +

        tools/md5: a small BSD compatible md5 tool written in pure perl.

        +

        +

        +
        +

        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:

        +
        +
        +
        +

        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.

        +
        + +
        +

        This copyright does not prohibit distribution of any version of Perl +containing this extension under the terms of the GNU or Artistic +licenses.

        +

        +

        +
        +

        AUTHORS

        +

        The original MD5 interface was written by Neil Winton +(<N.Winton (at) axion.bt.co.uk>).

        +

        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>.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5/Crypt.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5/Crypt.html new file mode 100644 index 0000000..dd9939d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MD5/Crypt.html @@ -0,0 +1,313 @@ + + + + +unix_md5_crypt - Provides interoperable MD5-based crypt function + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        unix_md5_crypt - Provides interoperable MD5-based crypt() function

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::MD5::Crypt;
        +
        +    $cryptedpassword = unix_md5_crypt($password, $salt);
        +
        +    $valid = $cryptedpassword eq unix_md5_crypt($password, $cryptedpassword);
        +

        +

        +
        +

        DESCRIPTION

        +

        the 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
        +

        apache_md5_crypt() provides a function compatible with Apache's +.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.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MIMETypes.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MIMETypes.html new file mode 100644 index 0000000..5e34041 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/MIMETypes.html @@ -0,0 +1,317 @@ + + + + +GT::MIMETypes - Methods to guess MIME Types of files. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::MIMETypes - Methods to guess MIME Types of files.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::MIMETypes;
        +
        +    my $file = '/foo/bar/abc.doc';
        +    my $mime = GT::MIMETypes::guess_type($file);
        +    my $img  = GT::MIMETypes::guess_image($file);
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::MIMETypes provides two simple methods guess_type and guess_image. +They take either a filename or a hash reference.

        +

        guess_type returns the MIME type of the file, and guess_image returns an +image name that represents the file.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: MIMETypes.pm,v 1.27 2009/02/18 19:17:17 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail.html new file mode 100644 index 0000000..9ad1596 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail.html @@ -0,0 +1,524 @@ + + + + +GT::Mail - A simple interface to parsing, sending, and creating email. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail - A simple interface to parsing, sending, and creating email.

        +

        +

        +
        +

        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";
        +

        +

        +
        +

        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.

        +

        +

        +

        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.

        +
        +
        debug + +
        +

        Sets the debug level for this object. Anything but zero will produce ouput on +STDERR.

        +
        + +
        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).

        +
        + +
        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.

        +
        + +
        +

        +

        +

        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 the GT::Mail::Parse manpage object is created when +needed.

        +

        +

        +

        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 +the GT::Mail::Parts manpage 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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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 the GT::Mail::Parts manpage. 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 the GT::Mail::Parts manpage for more details on this object.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        as_string - Getting the email as a string.

        +

        Same as to_string.

        +

        +

        +

        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).

        +

        +

        +

        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.

        +

        +

        +

        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 +the GT::Mail::Parse manpage.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/BulkMail.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/BulkMail.html new file mode 100644 index 0000000..510241a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/BulkMail.html @@ -0,0 +1,538 @@ + + + + +GT::Mail::BulkMail - A simplified interface to sending bulk emails + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::BulkMail - A (perhaps overly) simplified interface to sending bulk emails

        +

        +

        +
        +

        SYNOPSIS

        +
        +    $mailer = new GT::Mail::BulkMail;
        +    $mailer->option("setting");
        +    $mailer->otheroption("othersetting");
        +    ...
        +    
        +    -- or --
        +
        +    $mailer = new GT::Mail::BulkMail(
        +        -option      => "setting",
        +        -otheroption => "othersetting",
        +        ...
        +    );
        +
        +    -- then --
        +
        +    sub subroutine {
        +        # Code to generate the next e-mail address
        +    }
        +    open FILE, "email_list.txt";
        +    %hash = ( 1 => 'some@fictional.address',
        +              2 => 'who@knows.where'
        +            );
        +    @array = ('yet@another.fictional.address','and@one.more');
        +    $mailer->send(\&subroutine,\*FILE,\%hash,\@array);
        +    close FILE;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::BulkMail is a module to handle mass mailings. It is capable of +using either sendmail, or an SMTP server. It has the advantage of +not requiring multiple connections to the SMTP server.

        +

        +

        +
        +

        REQUIREMENTS

        +

        Perl 5.004

        +

        +

        +

        METHODS

        +

        All methods can be specified at object creation time as an option with the: +-option => value syntax. For example, $mailer = new GT::Mail::BulkMail(-from => "foo@bar.com") +would have the same effect as: $mailer = new GT::Mail::BulkMail(); $mailer->from("foo@bar.com")

        +
        +
        smtp + +
        +

        Sets the SMTP server to use, and sets the object mail sending method to use SMTP. Takes +SMTP server as argument.

        +
        + +
        sendmail + +
        +

        Sets the sendmail executable to use. Takes the path to sendmail as the argument.

        +
        + +
        text + +
        +

        Specifies that the mail format is text. This translates into Content-type: text/plain. +This is the default format.

        +
        + +
        html + +
        +

        Specifies that the mail format is HTML. (Content-type: text/html)

        +
        + +
        headers + +
        +

        Returns any custom headers set as a hash reference in scalar context, or a hash in list context.

        +
        + +
        add_header + +
        +

        Adds a single header. This can be any header starting with ``X-'' (Note that X-Mailer headers +will be prepended with the GT::Mail::BulkMail X-Mailer header (which includes the perl version, +OS name, GT::Mail::BulkMail module and CVS versions, and the Gossamer Threads homepage)). Pass +two arguments: A key (header name) and a value (header value). For example, for +X-Foo: blah blah blah you would use: $mailer->add_header(``X-Foo'' => ``blah blah blah'')

        +
        + +
        add_headers + +
        +

        Same as above, except it adds multiple headers. Has the same argument format. You would use: +$mailer->add_headers(``X-Foo1'' => ``blah'', ``X-Foo2'' => ``blah blah'');

        +
        + +
        delete_header + +
        +

        Deletes a single header. Pass the name of the header to delete.

        +
        + +
        delete_headers + +
        +

        Delete multiple headers. Pass a list of names of headers to delete.

        +
        + +
        from + +
        +

        Sets the ``from'' field of the e-mail. Must be set before $mailer->send() can be called. +Must be set to an e-mail address. If this e-mail address is rejected by the SMTP server, +no e-mails will be sent.

        +
        + +
        name + +
        +

        Sets the ``name'' field of the e-mail. This affects what is displayed in the ``From'' field. +When sending the email, the actual field will be set to: "This name" <some@name.net>. +Optional.

        +
        + +
        subject + +
        +

        Sets the subject of the message. If not specified, it will default to ``(no subject)''

        +
        + +
        message + +
        +

        The body of the message. Can be left blank, but that seems rather pointless... +The message will be encoded using the quoted-printable format if it contains characters +outside the 7-bit range.

        +
        + +
        success + +
        +

        A code reference to be run for each and every successful e-mail sending. +Each call to this code reference will be given the e-mail address as the only argument +(unless using a message ID, which is discussed below). Optional.

        +
        + +
        failure + +
        +

        A code reference that will be run for any email addresses that cannot be sent. Each +call to this code reference will be given the ID or e-mail address as the argument +(message IDs are discussed below). Optional.

        +
        + +
        frompresend + +
        namepresend + +
        subjectpresend + +
        messagepresend + +
        +

        A code reference that will be run before sending an e-mail. The 'from', 'name', 'subject', +or 'message' field will be sent to the code references (depending on which method called) +and whatever is returned will be used as the actual field for the email sent. This can be +used to parse fields to customize them for each recipient. The subroutine is called with +two arguments: (ID_OR_EMAIL, FIELD). If an ID is provided, it will be passed as the +first argument, otherwise the email address will be passed. The second argument is the +field itself. The field used in the actual email to the user will be the value returned by +the subroutine.

        +
        +
        +

        The default field (for the rest of the mailing) can be changed by directly modifying $_[1] +itself.

        +
        +
        +

        If the subroutine reference returns an undefined value, the mailer will use the actual field +instead. You can use this technique to only modify some messages, but not others.

        +
        +
        +

        Optional.

        +
        + +
        show_errors + +
        +

        If set to something true it will warn() on all errors. Optional. The default is turned on, +but can easily be changed by modifying the line '

        +
        + +
        error_code + +
        +

        Takes a code reference - the code reference will be called with the error as the argument +when an error occurs. Optional.

        +
        + +
        send + +
        +

        Takes any number of the following arguments:

        +
        +
        +
        array reference + +
        +

        An array reference of a list of e-mail addresses to send to. After each message, either the +success or failure callback will be called with the e-mail address as the argument, and +possibly a message as the second argument.

        +
        + +
        hash reference + +
        +

        A hash reference of ID => email pairs. For example, +123 => 'someone@whoknows.com'. The value will be used as the e-mail address to send +to, and the key will be an identifier to pass into the success or failure callbacks.

        +
        + +
        glob reference + +
        +

        A glob reference to an open file. Make sure the file is opened before passing this! +The file should contain one e-mail address per line.

        +
        + +
        subroutine or code reference + +
        +

        You may pass a code reference, and it will be called for each e-mail address. It is +assumed that the subroutine will return one e-mail address each time called, and +that a return value of ``undef'' indicates that there are no more e-mail addresses. +The code reference could alternatively return two items - if it does, it is assumed that +the first is an ID code, and that the second is the email address. When a call to either +or the success or failure callbacks, the ID will be provided as the first argument +instead of the e-mail address itself.

        +
        +
        +

        One cool feature to note about using code refs is that you can call next() from within +the code reference and it will then recall the code reference for the next value.

        +
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Editor.html new file mode 100644 index 0000000..8bea1a1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Editor.html @@ -0,0 +1,459 @@ + + + + +GT::Mail::Editor - E-mail template editor + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Editor - E-mail template editor

        +

        +

        +
        +

        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%>
        +

        +

        +
        +

        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.

        +

        +

        +

        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.

        +
        +
        dir + +
        +

        Defines the base directory of templates.

        +
        + +
        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.

        +
        + +
        file + +
        +

        Specify the filename of the template inside the directory already specified with +'dir' and 'template'

        +
        + +
        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.

        +
        + +
        +

        +

        +

        tpl_save - Save a template

        +
        +
        dir template file + +
        +

        See the entries in tpl_load

        +
        + +
        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).

        +
        + +
        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.

        +
        + +
        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.

        +
        + +
        +

        +

        +

        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.

        +

        +

        +

        new

        +

        Constructs a new GT::Mail::Editor object. This will be done automatically when +using the template methods tpl_load and tpl_save. Takes the following +arguments:

        +
        +
        dir + +
        +

        Defines the base directory of templates.

        +
        + +
        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.

        +
        + +
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Encoder.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Encoder.html new file mode 100644 index 0000000..f3bf0cc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Encoder.html @@ -0,0 +1,367 @@ + + + + +GT::Mail::Encoder - MIME Encoder + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Encoder - MIME Encoder

        +

        +

        +
        +

        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;
        +

        +

        +
        +

        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!).

        +

        +

        +

        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.

        +
        +
        debug + +
        +

        Set debugging level. 1 or 0.

        +
        + +
        encoding + +
        +

        Sets the encoding used to encode.

        +
        + +
        in + +
        +

        Set to a file handle or IO handle.

        +
        + +
        out + +
        +

        Set to a code reference, the decoded stream will be passed in at the first +argument for each chunk encoded.

        +
        + +
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Encoder.pm,v 1.44 2008/10/29 23:31:51 brewt Exp $ + +

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Message.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Message.html new file mode 100644 index 0000000..55853c6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Message.html @@ -0,0 +1,399 @@ + + + +GT::Mail::Message - Encapsolates an email message. + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Message - Encapsolates an email message.

        +

        +

        +
        +

        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;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::Message encapsolates a mime message which consists of +the GT::Mail::Parts manpage object. This module provides methods to change, +move, remove, and access these parts.

        +

        +

        +

        Creating a new GT::Mail::Message object

        +

        Usually you will get a GT::Mail::Message object by call the parse method +in the GT::Mail::Parse manpage.

        +
        +    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
        +    );
        +

        +

        +

        Creating a new Part

        +

        You can create a part by calling new on the GT::Mail::Parts manpage 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 the GT::Mail::Parts manpage such as body_path(). Anything +that is not body_path, body_data, or body_handle is treated +as header values.

        +

        +

        +

        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.

        +

        +

        +

        Accessing Parts

        +

        More to come!

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $ + +

        +
        +        
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/POP3.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/POP3.html new file mode 100644 index 0000000..b72a5d4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/POP3.html @@ -0,0 +1,597 @@ + + + + +GT::Mail::POP3 - Receieve email through POP3 protocal + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::POP3 - Receieve email through POP3 protocal

        +

        +

        +
        +

        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;
        +        }
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::POP3 is a module to check an email account using the POP3 protocol. +Many of the methods are integrated with the GT::Mail::Parse manpage.

        +

        +

        +

        new - constructor method

        +

        This method is inherited from the GT::Base manpage. 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.

        +
        +
        debug + +
        +

        Sets the debugging level for this instance of GT::Mail::POP3.

        +
        + +
        host + +
        +

        Sets the host to connect to for checking a POP account. This argument must be +provided.

        +
        + +
        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.

        +
        + +
        ssl + +
        +

        Establishes the connection using SSL. Note that this requires Net::SSLeay of +at least version 1.06.

        +
        + +
        user + +
        +

        Sets the user name to login with when connecting to the POP server. This must +be specified.

        +
        + +
        pass + +
        +

        Sets the password to login with when connection to the POP server. This must be +specified.

        +
        + +
        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.

        +
        + +
        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.

        +
        + +
        +

        +

        +

        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.

        +

        +

        +

        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 the GT::Mail::Parts manpage object containing only the parsed header of the +specified message.

        +

        +

        +

        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 the GT::Mail::Parts manpage object. One object for each +email. None of the email's bodies are retrieved, only the head.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +
        +

        REQUIREMENTS

        +

        the GT::Socket::Client manpage +the GT::Base manpage +the GT::MD5 manpage (for APOP authentication)

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parse.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parse.html new file mode 100644 index 0000000..bce4145 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parse.html @@ -0,0 +1,422 @@ + + + + +GT::Mail::Parse - MIME Parse + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Parse - MIME Parse

        +

        +

        +
        +

        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;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::Parse is a 100% rfc822 email MIME parser that supports unlimited +nested levels of MIME. Emails are parsed into the GT::Mail::Parts manpage objects. Each +part knows where it's body is and each part contains it's sub parts. See +the GT::Mail::Parts manpage for details on parts methods.

        +

        +

        +

        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().

        +
        +
        debug + +
        +

        Sets the debug level for this insance of the class.

        +
        + +
        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.

        +
        + +
        in_file + +
        +

        Specify the path to the file that contains the email to be parsed. One of in_file +and handle must be specified.

        +
        + +
        handle + +
        +

        Specify the file handle or IO stream that contains the email to be parsed.

        +
        + +
        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.

        +
        + +
        +

        +

        +

        parse - Parse an email

        +

        Instance method. Parses the email specified by either in_file or handle. Returns +the top level the GT::Mail::Parts manpage object. Any additional parameters passed in are +treated the same as if they were passed to the constuctor.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Parse.pm,v 1.90 2008/10/29 23:32:07 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parts.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parts.html new file mode 100644 index 0000000..10a4e68 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Parts.html @@ -0,0 +1,573 @@ + + + + +GT::Mail::Parts - Data storage class for MIME parts + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Parts - Data storage class for MIME parts

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Mail;
        +
        +    my $mail = new GT::Mail;
        +
        +    my $top_part = $mail->parse('/path/to/email');
        +
        +    # Access the emails as an array
        +    my @to   = $top_part->split_field('to');
        +    my @from = $top_part->split_field('from');
        +
        +    # Access to the header fields
        +    my $mailer  = $top_part->get('X-Mailer');
        +    my $subject = $top_part->get('Subject');
        +
        +    # Access to this parts sub part
        +    if ($top_part->is_multipart) {
        +        my @parts = $top_parts->parts;
        +        for my $part (@parts) {
        +
        +            # Access parts of the header
        +            print "Filename: ", $part->recommended_filename, "\n";
        +            print "Part is multi-part\n" if $part->is_multipart;
        +
        +            # Get the body as a string
        +            my $body = $part->body_as_string;
        +        }
        +    }
        +
        +    # Change who it is to
        +    $top_part->set('to', 'scott@gossamer-threads.com');
        +
        +    # Remove the bcc line
        +    $top_part->delete('bcc');
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::Parts is a class to provide methods to change and +access a MIME messages. The object for this class is meant to +be istansiated from the GT::Mail manpage.

        +

        +

        +

        effective_type - Access the effective MIME type

        +
        +    my $type = $obj->effective_type;
        +
        +    if ($type eq 'application/octet-stream') {
        +        ...
        +    }
        +

        This method returns the effective MIME Type of this objects part.

        +

        +

        +

        get - Access header tags.

        +
        +    my $subj = $obj->get('Subject');
        +
        +    # or if there is more than one
        +    my @recv = $obj->get('Received');
        +

        Used to access any of the tags in the header of the MIME part. If the +tag requested is not present returns false. The first argument to this +method is the name of he tag you want to extract. This is case insensitive.

        +

        +

        +

        set - Set a header tag.

        +
        +    # Change who the email is to
        +    $obj->set('to', 'scott@gossamer-threads.com');
        +
        +    # Change the second Received tag
        +    $obj->set('Received', 'from unknown', 1);
        +

        Set any of the tags in the header. If the tag does not exist this will create +it. This method takes three arguments. The first is the name of the tag to +change or add, this is case insensitive. The second argument is the value for +the tag. The third zero based optional argument is the position. The position +will default to zero if it is not specified.

        +

        +

        +

        delete - Remove a header tag.

        +
        +    # Delete who the message is from
        +    $obj->delete('from');
        +

        This method deletes the tag specified by the first argument from this MIME +part.

        +

        +

        +

        size - Access the total size.

        +
        +    my $size = $obj->size;
        +

        This method returns the total size of this part. This includes the header and +the body.

        +

        +

        +

        preamble - Set or get the preamble.

        +
        +    # Retrieve the preamble
        +    my $pre = $obj->preamble;
        +
        +    # Set the preamble
        +    $obj->preamble('This is a multi-part message in MIME format.');
        +

        This is a set get method for the preamble. The preamble is the part after the +head but before the first MIME boundary. This method makes no since if this +is not a multi-part part.

        +

        +

        +

        epilogue - Set or get the epilogue.

        +
        +    # Retrieve the epilogue
        +    my $ep = $obj->epilogue;
        +
        +    # Set the epilogue
        +    $obj->epilogue('This is my cool epilogue');
        +

        This is a set get method for the epilogue. The epilogue is the part of the +MIME part after the MIME boundary and before the next head. This method makes +no since if this is not a multi-part part.

        +

        +

        +

        mime_type - Set or get the MIME type.

        +
        +    my ($type, $subtype) = split('/', $obj->mime_type);
        +

        This method returns the MIME type of this part. You can pass in an argument +to change the MIME type as well. So you could do

        +
        +    $obj->mime_type('text/plain');
        +

        This is probably not such a good idea unless you are constructing the email from +scratch.

        +

        +

        +

        is_multipart - See if you have a multi-part part.

        +
        +    if ($obj->is_multipart) {
        +        # do some multi-part stuff
        +    }
        +

        Returns true is this part is a multi-part MIME part.

        +

        +

        +

        parts - Access sub parts.

        +
        +    my @parts = $obj->parts;
        +

        Returns the parts object this part contains. Returns false if this part does +no have any sub parts. The parts objects that returns are from this same class. +Any parts that are milti-part should contain parts.

        +

        +

        +

        multipart_boundary - Set or get the multi-part boundary.

        +
        +    my $boundary = $obj->multipart_boundary;
        +

        This returns the multi-part boundary for this part. Setting this is never needed +and may be removed in the future. This method only makes since if you are working +with a multi-part pert.

        +

        +

        +

        header_as_string - Access the whole header.

        +
        +    my $head = $obj->header_as_string;
        +

        This method creates and returns the header for this part. The returned header should +be fully rfc822 compliant. Avoid calling this method more than once, as it will build +the header from an internal data structure each time.

        +

        +

        +

        split_field - Retrieve the emails split up into an array.

        +
        +    my @to  = $obj->split_field; # Defaults to 'to'
        +    my @bcc = $obj->split_field('bcc');
        +

        This is mostly a utility method. It takes an option argument as to the field you want +the email address from (default is to), it then splits the emails on '\s*,\s*' that is +not inside quotes. Returns an array of the split up string.

        +

        +

        +

        suggest_encoding - Get a suggestion for encoding.

        +
        +    my $encode = $obj->suggest_encoding;
        +

        Returns a suggested encoding for the body of this message. This is useful to decide +what encoding you should use for the body when building an email. This is used in +the GT::Mail::Parse manpage to decide how to encode the message body.

        +

        +

        +

        recommended_filename - Figure out the file name.

        +
        +    my $file = $obj->recommended_filename;
        +    if ($file) {
        +        ...
        +    }
        +

        This method tries to figure out the file name of this part. This does not make much +since if this part is not an attachment of some kind. Returns an empty string on +failure.

        +

        +

        +

        body_as_string - Get the body as a string.

        +

        This method returns the entire body of the MIME message as a string. You should not +use this method if the body could be large.

        +

        +

        +

        body_in - Find the body.

        +
        +    my $in = $obj->body_in;
        +    my $body;
        +
        +    if ($in eq 'MEMORY') {
        +        $body = $obj->body_data;
        +    }
        +    elsif ($in eq 'HANDLE') {
        +        $body = $obj->body_handle;
        +    }
        +    elsif ($in eq 'FILE') {
        +        $body = $obj->body_path;
        +    }
        +

        This method returns the location of the body. The location can be one of three things:

        +
        +
        MEMORY + +
        +

        The body is in a string.

        +
        + +
        HANDLE + +
        +

        The body is in an IO handle.

        +
        + +
        FILE + +
        +

        The body is in a file.

        +
        + +
        +

        You would use this to decide what method to use to access the body. If the MIME message +was parsed into GT::Mail::Parts using the GT::Mail::Parser manpage the body will always be in +a FILE.

        +

        +

        +

        body_data - Get the in memory body.

        +

        This method returns the body if it is stored in memory. Returns undefined if the body is +not in memory.

        +

        +

        +

        body_handle - Get an IO handle to the body.

        +

        This method returns a handle to the body if the body is stored in a handle for this part. +Returns undefined if not.

        +

        +

        +

        body_path - Get the location of the file the body is in.

        +

        This method returns the file path to the file the body is located in if the body for this +part is stored in a file. Returns undefined if not.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        $Revision: 1.84 $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Send.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Send.html new file mode 100644 index 0000000..5ee13f2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Mail/Send.html @@ -0,0 +1,393 @@ + + + + +GT::Mail::Send - Module to send emails + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Mail::Send - Module to send emails

        +

        +

        +
        +

        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;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Mail::Send is an object interface to sending email over either +SMTP or Sendmail. This module is used internally to GT::Mail.

        +

        +

        +

        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.

        +
        +
        debug + +
        +

        Sets the debug level for this instance of GT::Mail::Send.

        +
        + +
        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.

        +
        + +
        host + +
        +

        Specify the host to use when sending by SMTP.

        +
        + +
        port + +
        +

        Specify the port to use when sending over SMTP. Defaults to 25.

        +
        + +
        helo + +
        +

        The hostname to output on the HELO/EHLO line on an SMTP connection. Defaults to +$ENV{SERVER_NAME} or the system hostname (if Sys::Hostname is available).

        +
        + +
        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.

        +
        + +
        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.

        +
        + +
        +

        +

        +

        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.

        +

        +

        +

        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.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/2CheckOut.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/2CheckOut.html new file mode 100644 index 0000000..7efe97b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/2CheckOut.html @@ -0,0 +1,556 @@ + + + + +GT::Payment::Remote::2CheckOut - 2CheckOut payment handling + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Payment::Remote::2CheckOut - 2CheckOut payment handling

        +

        +

        +
        +

        CAVEATS

        +

        2CheckOut has a pretty weak automated payment system - the security of the +entire automated payment process hinges on your ``Secret Word'' (Admin -> Account +Details -> Return -> Secret Word (near the bottom of the page)) - without it, +there is no security at all. Another weakness in the system is that if your +server is not reachable for whatever reason, the payment information would be +lost. Payment providers like 2CheckOut and WorldPay would do well to learn +from payment systems like that of PayPal - whatever can be said about other +aspects of PayPal, they do have one of the nicest payment systems around - both +from a developer and user's point of view.

        +

        Because of the security issue with not using the ``Secret Word'', this module +requires that the secret word be used, even if other 2CheckOut systems may not. +Additionally, the default secret word of ``tango'' is not allowed.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Payment::Remote::2CheckOut;
        +    use GT::CGI;
        +
        +    my $in = new GT::CGI;
        +
        +    GT::Payment::Remote::2CheckOut->process(
        +        param => $in,
        +
        +        on_valid => \&valid,
        +
        +        sellerid => "1234",
        +        password => "Some Good Secret Word"
        +    );
        +
        +    sub valid {
        +        # Update database - the payment has been made successfully.
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is designed to handle 2CheckOut payment processing.

        +

        +

        +
        +

        REQUIREMENTS

        +

        GT::CGI and GT::MD5.

        +

        +

        +
        +

        FUNCTIONS

        +

        This module has only one function: process() does the work of actually +figuring out what to do with a postback.

        +

        +

        +

        process

        +

        process() is the only function provided by this module. It can be called as +either a function or class method, and takes a hash (not hash reference) of +arguments as described below.

        +

        process() should be called for 2CheckOut initiated postbacks. This can be set +up in your main .cgi by looking for 2CheckOut-specific CGI parameters +('cart_order_id' is a good one to look for) or by making a seperate .cgi file +exclusively for handling 2CheckOut postbacks.

        +

        Additionally, it is strongly advised that database connection, authenticate, +etc. be performed before calling process() to ensure that the payment is +recorded successfully. 2CheckOut will not attempt to repost the form data if +your script produces an error, and the error will be shown to the customer.

        +
        +
        param + +
        +

        param takes a GT::CGI object from which 2CheckOut postback variables are read.

        +
        + +
        on_valid + +
        +

        on_valid takes a code reference as value. The code reference will be called +when a successful payment has been made. Inside this code reference you are +responsible for setting a ``paid'' status for the order in question. The +cart_order_id CGI variable will have whatever cart_order_id you provided.

        +
        + +
        sellerid + +
        +

        This should be passed to seller number. This is needed, along with the +password field below, to verify that the posted payment is a genuine 2CheckOut +payment.

        +
        + +
        password + +
        +

        This is a ``Secret Word'' that the admin must set in the 2CheckOut admin area +(under Look & Feel -> Secret Word). This field must be set in the admin, and +passed in here. Note that the default value, ``tango'', is not allowed. Without +this password, 2CheckOut postbacks should not be considered secure.

        +
        + +
        demo + +
        +

        Whether or not to initiate and accept demo transactions.

        +
        + +
        +

        +

        +
        +

        INSTRUCTIONS

        +

        To implement 2CheckOut payment processing, there are a number of steps required +in addition to this module. Basically, this module handles only the postback +stage of the 2CheckOut payment process.

        +

        +

        +

        Directing customers to 2CheckOut

        +

        This is done by creating a web form containing the following variables. Your +form, first of all, should post to +https://www.2checkout.com/2co/buyer/purchase. See +https://www.2checkout.com/documentation/UsersGuide2/third_party_carts/2co-system-parameters.html +for a complete and up-to-date list of parameters that can be passed to 2CheckOut.

        +

        Required fields are as follows:

        +
          +
        • sid + +
          +
          +Your 2CheckOut account number
          +
        • total + +

          The total amount to be billed, in DD.CC format.

          +
        • +
        • cart_order_id + +

          A unique order id, which you should store to track the payment.

          +
        • +
        +

        The following parameters *may* be passed in, and will be available in the +postback:

        + +

        In the postback CGI, you'll get back all of the billing and shipping variables +listed above, plus:

        +
          +
        • order_number + +

          2CheckOut order number

          +
        • +
        • cart_order_id + +
        • cart_id + +

          Your order number, passed back. Both variables are the same.

          +
        • +
        +

        +

        +

        Postback

        +

        Before 2CheckOut postback notification can occur, you must set up the postback +(in 2CheckOut terminology, ``Routine''). This can be set from the Admin -> +Shopping Cart -> Cart Details. You need to enable the payment routine, and +set it to a CGI that you manage.

        +

        +

        +

        Putting it all together

        +

        The typical way to implement all of this is as follows:

        +
          +
        1. Get necessary merchant information (sid and secret keyword) + +
        2. Once the customer has selected what to purchase, generate a +cart_order_id (a random MD5 hex string works well), and store it somewhere +(i.e. in the database). + +
        3. Make a form with all the necessary fields that +submits to 2CheckOut. + +
        4. Set up the on_valid callback. If using a dedicated +CGI script for 2CheckOut callbacks, it should just call process(); otherwise, +check for the CGI parameter 'cart_order_id' and if present, call process(). + +
        5. For a valid payment, do whatever you need to do for a valid payment, +and store some record of the payment having been made (storing at least the +cart_order_id and the order_number is strongly recommended). Use the CGI +parameter 'cart_order_id' to locate the order (i.e. in the database). + +
        +

        +

        +
        +

        SEE ALSO

        +

        http://www.2checkout.com - 2CheckOut website.

        +

        http://www.support.2checkout.com/deskpro/faq.php - 2CheckOut knowledgebase

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: 2CheckOut.pm,v 1.5 2006/08/22 20:39:04 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/PayPal.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/PayPal.html new file mode 100644 index 0000000..5e4a5b5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/PayPal.html @@ -0,0 +1,729 @@ + + + + +GT::Payment::Remote::PayPal - PayPal payment handling + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Payment::Remote::PayPal - PayPal payment handling

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Payment::Remote::PayPal;
        +    use GT::CGI;
        +
        +    my $in = new GT::CGI;
        +
        +    GT::Payment::Remote::PayPal->process(
        +        param => $in,
        +        on_valid => \&valid,
        +        on_pending => \&pending,
        +        on_failed => \&failed,
        +        on_denied => \&denied,
        +        on_invalid => \&invalid,
        +        on_recurring => \&recurring,
        +        on_recurring_signup => \&r_signup,
        +        on_recurring_cancel => \&r_cancel,
        +        on_recurring_failed => \&r_failed,
        +        on_recurring_eot => \&r_eot,
        +        on_recurring_modify => \&r_modify,
        +        duplicate => \&duplicate,
        +        email => \&email,
        +        on_error => \&error
        +    );
        +
        +    sub valid {
        +        # Update database - the payment has been made successfully.
        +    }
        +    sub pending {
        +        # Optional; store a "payment pending" status if you wish.  This is optional
        +        # because another postback will be made with a completed, failed, or denied
        +        # status.
        +    }
        +    failed {
        +        # According to PayPal IPN documentation: "The payment has failed.  This
        +        # will only happen if the payment was made from your customer's bank
        +        # account."
        +        # Store a "payment failed" status for the order
        +    }
        +    sub denied {
        +        # According to PayPal IPN documentation: "You, the merchant, denied the
        +        # payment.  This will only happen if the payment was previously pending due
        +        # to one of the "pending reasons" [in pending_reason]"
        +    }
        +    sub invalid {
        +        # This means the request did NOT come from PayPal.  You should log the
        +        # request for follow up.
        +    }
        +    sub recurring {
        +        # This means a recurring payment has been made successfully.  Update
        +        # database.
        +    }
        +    sub r_signup {
        +        # This means a recurring signup has been made (NOT a payment, just a
        +        # signup).
        +    }
        +    sub r_cancel {
        +        # The user has cancelled their recurring payment
        +    }
        +    sub r_failed {
        +        # A recurring payment has failed (probably declined).
        +    }
        +    sub r_eot {
        +        # A recurring payment has come to its natural conclusion.  This only
        +        # applies to payments with a set number of payments.
        +    }
        +    sub r_modify {
        +        # Something has been modified regarding the recurring payment
        +    }
        +    sub duplicate {
        +        # Check to see if the payment has already been made.  If it _has_ been
        +        # made, you should return undef, otherwise return 1 to indicate that this
        +        # is not a duplicate postback.  The "txn_id" value is passed in, but is
        +        # also available through $in->param('txn_id').
        +    }
        +    sub email {
        +        # This will be called with an e-mail address.  You should check to make
        +        # sure that the e-mail address entered is the same as the one on the PayPal
        +        # account.  Return true (1) if everything checks out, undef otherwise.
        +    }
        +    sub error {
        +        # An error message is passed in here.  This is called when a error such as
        +        # a connection problem or HTTP problem occurs.
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is designed to handle PayPal payment processing using PayPal's IPN +system. It does very little other than generating and sending a proper +response to the PayPal server, and calling the provided code reference(s).

        +

        It is strongly recommended that you familiarize yourself with the PayPal +``Single Item Purchases Manual'' and ``IPN Manual'' listed in the SEE ALSO +section of this document.

        +

        +

        +
        +

        REQUIREMENTS

        +

        GT::WWW with the https protocol, which in turn requires Net::SSLeay. PPM's are +available from Gossamer Threads for the latest Windows releases of ActiveState +Perl 5.6.1 and 5.8.0.

        +

        +

        +
        +

        process

        +

        process() is the only function/method provided by this module. It can be +called as either a function or class method, and takes a hash (not hash +reference) of arguments as described below. This module requires GT::WWW's +https interface, which in turn requires Net::SSLeay.

        +

        process() should be called for PayPal initiated requests. This can be set up +in your main CGI by looking for PayPal-specific CGI parameters ('txn_type' is a +good one to look for) or by making a seperate .cgi file exclusively for +handling IPN postbacks.

        +

        Additionally, it is strongly advised that database connection, authenticate, +etc. be performed before calling process() to ensure that the payment is +recorded successfully. If your CGI script has an error, PayPal will retry the +postback again

        +

        Except where indicated, all arguments are required.

        +

        +

        +

        param

        +

        param takes a GT::CGI object from which PayPal IPN variables are read.

        +

        +

        +

        on_valid

        +

        on_valid takes a code reference as value. The code reference will be called +when a successful payment has been made. Inside this code reference you are +responsible for setting a ``paid'' status for the order in question.

        +

        See the PayPal IPN documentation listed below for information on how to +identify an order.

        +

        +

        +

        on_pending

        +

        on_pending is called when PayPal sends information on a ``Pending'' payment. +This parameter is optional, due to the fact that a ``Pending'' status means that +another notification (either ``Completed'', ``Failed'', or ``Denied'') will be made.

        +

        It is, however, recommended that when a Pending payment is encountered, a note +be stored in your application that manual intervention is probably required.

        +

        According to PayPal documentation, there are a few cases where this will +happen, which can be obtained from the ``pending_reason'' CGI input variable. +The possible values and what each means follows (this comes straight from the +PayPal documentation).

        +
        +
        ``echeck'' + +
        +

        The payment is pending because it was made by an eCheck, which has not yet +cleared.

        +
        + +
        ``multi_currency'' + +
        +

        You do not have a balance in the currency sent, and you do not have your +Payment Receiving Preferences set to automatically convert and accept this +payment. You must manually accept or deny this payment.

        +
        + +
        ``intl'' + +
        +

        The payment is pending because you, the merchant, hold an international account +and do not have a withdrawal mechanism. You must manually accept or deny this +payment from your Account Overview.

        +
        + +
        ``verify'' + +
        +

        The payment is pending because you, the merchant, are not yet verified. You +must verify your account before you can accept this payment.

        +
        + +
        ``address'' + +
        +

        The payment is pending because your customer did not include a confirmed +shipping address and you, the merchant, have your Payment Receiving Preferences +set such that you want to manually accept or deny each of these payments. To +change your preference, go to the ``Preferences'' section of your ``Profile.''

        +
        + +
        ``upgrade'' + +
        +

        The payment is pending because it was made via credit card and you, the +merchant, must upgrade your account to Business or Premier status in order to +receive the funds.

        +
        + +
        ``unilateral'' + +
        +

        The payment is pending because it was made to an email address that is not yet +registered or confirmed.

        +
        + +
        ``other'' + +
        +

        The payment is pending for an ``other'' reason. For more information, contact +customer service.

        +
        + +
        +

        +

        +

        on_failed

        +

        Takes a code reference to call in the event of a failed payment notification. +A failed payment ``will only happen if the payment was made from your customer's +bank account.''

        +

        You should record a failed payment in your application.

        +

        +

        +

        on_denied

        +

        This code reference is called when a ``Denied'' payment notification is received. +``This will only happen if the payment was previously pending due to one of the +'pending reasons''' above.

        +

        You should record a failed or denied payment in your application.

        +

        +

        +

        on_invalid

        +

        This code reference will be called when an invalid request is made. This +usually means that the request did not come from PayPal. According to +PayPal, ``if you receive an 'INVALID' notification, it should be treated as +suspicious and investigated.'' Thus it is strongly recommended that a record of +the invalid request be made.

        +

        +

        +

        duplicate

        +

        This code reference is required to prevent duplicate payments. It is called +for potentially successful requests to ensure that it is not a duplicate +postback. It is passed the ``txn_id'' CGI parameter, which is the +PayPal-generated transaction ID. You should check this parameter against your +order database. If you have already recorded this payment as successfully +made, should should return undef from this function, to indicate that the +duplicate check failed. If the transaction ID is okay (i.e. is not a +duplicate) return 1 to continue.

        +

        +

        +

        recurring

        +

        A successful recurring payment has been made. You should set a ``paid'' status +for the item in question.

        +

        +

        +

        recurring_signup

        +

        +

        +

        recurring_cancel

        +

        +

        +

        recurring_failed

        +

        +

        +

        recurring_eot

        +

        +

        +

        recurring_modify

        +

        These are called when various things have happened to the subscription. In +particular, signup refers to a new subscription, cancel refers to a cancelled +subscription, failed refers to a failed payment, eot refers to a subscription +that ended naturally (i.e. an end was set when the subscription was initially +made), and modify is called when a payment has been modified.

        +

        +

        +

        email

        +

        This code reference, like duplicate, is called to ensure that the payment was +sent to the correct account. An e-mail address is passed in which must be the +same as the primary account's e-mail address. If it is the same, return 1. +If it is not the same, you should return undef and store a note asking +the user to check that the PayPal e-mail address they have provided is the +correct, primary, PayPal e-mail address.

        +

        +

        +

        on_error

        +

        This code reference is optional, but recommended. It is called when a +non-PayPal generated error occurs - such as a failure to connect to PayPal. It +is recommended that you provide this code reference and log any errors that +occur. The error message is passed in.

        +

        +

        +
        +

        INSTRUCTIONS

        +

        To implement PayPal payment processing, there are a number of steps required in +addition to this module. Basically, this module handles only the postback +stage of the PayPal IPN process.

        +

        Full PayPal single item, subscription, and IPN documentation is available at +the URL's listed in the SEE ALSO section.

        +

        +

        +

        Directing customers to PayPal

        +

        This is done by creating a web form containing the following variables. Your +form, first of all, must post to https://www.paypal.com/cgi-bin/webscr.

        +

        Your form should contains various PayPal parameters, as outlined in the PayPal +manuals linked to in the SEE ALSO section.

        +

        Of particular note is the ``notify_url'' option, which should be used to specify +a postback URL for PayPal IPN postbacks. +The below is simply a list of the required fields, and only those fields that +are absolutely required are described. For descriptions of each field, check +the PayPal Single Item Purchases Manual.

        +
        +
        cmd + +
        +

        Must be set to ``_xclick''.

        +
        + +
        business + +
        +

        Your PayPal ID (e-mail address). Must be confirmed and linked to your Verified +Business or Premier account.

        +
        + +
        item_name + +
        item_number + +
        image_url + +
        no_shipping + +
        return + +
        +

        Although optional, this is highly recommend - takes a URL to bring the buyer +back to after purchasing. If not specified, they'll remain at PayPal.

        +
        + +
        rm + +
        +

        Return method for the return option. If ``1'', a GET request without +the transaction variables will be made, if ``2'' a POST request WITH the transaction +variables will be made.

        +
        + +
        cancel_return + +
        no_note + +
        cn + +
        cs + +
        on0 + +
        on1 + +
        os0 + +
        os1 + +
        quantity + +
        +

        The quantity of items being purchased. If omitted, defaults to 1 and will not +be shown in the payment flow.

        +
        + +
        undefined_quantity + +
        +

        ``If set to ''1``, the user will be able to edit the quantity. This means your +customer will see a field next to quantity which they must complete. This is +optional; if omitted or set to ''0``, the quantity will not be editable by the +user. Instead, it will default to 1''

        +
        + +
        shipping + +
        +

        +

        +

        IPN

        +

        Before PayPal payment notification can occur, you must instruct the user to +enable Instant Payment Notification (IPN) on their PayPal account. The +postback URL should be provided and handled by you either by detecting a PayPal +request in your main .cgi script (recommended), or through the use of an +additional .cgi script exclusively for PayPal IPN.

        +

        If adding to your existing script, it is recommended to look for the 'txn_type' +CGI parameter, which will be set for PayPal IPN postbacks.

        +

        Once IPN has been set up, you have to set up your application to direct users +to PayPal in order to initiate a PayPal payment.

        +

        +

        +
        +

        SEE ALSO

        +

        https://www.paypal.com/html/single_item.pdf - Single Item Purchases Manual

        +

        https://www.paypal.com/html/subscriptions.pdf - Subscriptions and Recurring +Payments Manual

        +

        https://www.paypal.com/html/ipn.pdf - IPN Manual

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: PayPal.pm,v 1.8 2006/04/08 03:42:05 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/WorldPay.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/WorldPay.html new file mode 100644 index 0000000..d978bc1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Payment/Remote/WorldPay.html @@ -0,0 +1,713 @@ + + + + +GT::Payment::Remote::WorldPay - WorldPay payment handling + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Payment::Remote::WorldPay - WorldPay payment handling

        +

        +

        +
        +

        CAVEATS

        +

        One thing to note about WorldPay is that its security system is a little weak - +you can't trust a callback post as actually being genuine, unless you use the +callback password feature - and even at that it is not a terribly secure +solution. In this regard, other payment provides have much cleaner transaction +systems. Another shortcoming of WorldPay is that its callback system is +somewhat weak - it won't try to inform you very hard: it tries once, but if it +doesn't connect it gives up and doesn't try again, making it entirely possible +and likely that you will have to manually add (or confirm) missing payments at +some point, so supporting at least manual payment approval of initiated +payments is absolutely required.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Payment::Remote::WorldPay;
        +    use GT::CGI;
        +
        +    my $in = new GT::CGI;
        +
        +    GT::Payment::Remote::WorldPay->process(
        +        param => $in,
        +        on_valid => \&valid,
        +        on_cancel => \&cancel,
        +
        +        on_recurring => \&recurring,
        +        on_recurring_failed => \&recurring_failed,
        +        on_recurring_cancelled => \&recurring_cancelled,
        +
        +        password => "123",
        +        on_invalid_password => \&invalid_pw
        +    );
        +
        +    sub valid {
        +        # Update database - the payment has been made successfully.
        +    }
        +
        +    sub cancel {
        +        # Update database - the user has clicked the "Cancel" button, thereby
        +        # cancelling the payment.  You should take note of the cancellation.
        +    }
        +
        +    sub on_recurring {
        +        # Update database - a recurring payment has been made successfully.
        +    }
        +
        +    sub on_recurring_failed {
        +        # Update database - a recurring payment has failed.
        +    }
        +
        +    sub on_recurring_cancelled {
        +        # Update database - either the customer or the merchant has cancelled
        +        # this recurring payment
        +    }
        +
        +    sub on_invalid_password {
        +        # Perhaps make a record - a payment callback was received without a
        +        # valid password
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is designed to handle WorldPay payment processing using WorldPay's +``Select Junior'' system and callback.

        +

        +

        +
        +

        REQUIREMENTS

        +

        GT::CGI is the only requirement, however GT::MD5 is required in order to use +the md5_signature function.

        +

        +

        +
        +

        FUNCTIONS

        +

        This module has only two functions. process() does the work of actually +figuring out what to do with a postback, and md5_signature() is used to +generate an MD5 signature for payment verification and security purposes. Both +functions can be imported into your package, and can be called as either method +or function.

        +

        +

        +

        process

        +

        process() is the main function provided by this module. It can be called as +either a function or class method, and takes a hash (not hash reference) of +arguments as described below.

        +

        process() should be called for WorldPay initiated postbacks. This can be set +up in your main CGI by looking for WorldPay-specific CGI parameters +('transStatus' is a good one to look for) or by making a seperate .cgi file +exclusively for handling WorldPay postbacks.

        +

        Additionally, it is strongly advised that database connection, authenticate, +etc. be performed before calling process() to ensure that the payment is +recorded successfully. WorldPay will not attempt to repost the form data if +your script produces an error, and the error will be shown to the customer.

        +

        The param argument, either on_valid or +on_recurring, and the password options +are required. Using MD5 signing as well is strongly advised.

        +
        +
        param + +
        +

        param takes a GT::CGI object from which WorldPay postback variables are read.

        +
        + +
        on_valid + +
        +

        on_valid takes a code reference as value. The code reference will be called +when a successful payment has been made. Inside this code reference you are +responsible for setting a ``paid'' status for the order in question.

        +
        + +
        on_cancel + +
        +

        Takes a code reference to call in the event of the customer clicking the +``cancel'' button. Note that this is not sent if the user closes their browser, +but only if they click ``cancel.''

        +
        +
        +

        You should record a cancelled payment in your application.

        +
        + +
        password + +
        +

        This is a password that the customer should set in the WorldPay Customer +Management System, and provide to you. Without this password, WorldPay +postbacks should not be considered secure.

        +
        + +
        on_invalid_password + +
        +

        This code reference will be called when the correct password is not present in +the postback request. This will also be called if no password is provided.

        +
        + +
        on_recurring + +
        on_recurring_failed + +
        on_recurring_cancelled + +
        +

        In order to support recurring payments, you must at least define +on_recurring. on_recurring is called when a successful recurring payment +has been made. on_recurring_failed is called for a failed recurring payment +(e.g. credit card declined). See +the Recurring charges section for more details.

        +
        +
        +

        Bear in mind that if you do not set up the on_recurring callback, recurring +payments will be ignored.

        +
        + +
        +

        +

        +

        md5_signature

        +

        The md5_signature() function takes a password (this must be set for the +WorldPay account), and a list of values and generates an appropriate WorldPay +MD5 signature, which should be included as the ``signature'' field. See +the MD5 signing section for more details.

        +

        +

        +
        +

        INSTRUCTIONS

        +

        To implement WorldPay payment processing, there are a number of steps required +in addition to this module. Basically, this module handles only the postback +stage of the WorldPay payment process.

        +

        Full WorldPay ``Select Junior'' information is available from the ``Select Junior +Integration Guide'' available from www.worldpay.com.

        +

        +

        +

        Directing customers to WorldPay

        +

        This is done by creating a web form containing the following variables. Your +form, first of all, must make a post request to +https://select.worldpay.com/wcc/purchase.

        +

        Required fields are as follows:

        +
        +
        instId + +
        +

        Your WorldPay Installation ID. Example: 1234

        +
        + +
        currency + +
        +

        The currency of the purchase. Example: GBP

        +
        + +
        desc + +
        +

        A description of the purchase. Example: Blue T-Shirt, Medium

        +
        + +
        cartId + +
        +

        A reference you assign to help you identify the purchase. Example: 10a0491.

        +
        + +
        amount + +
        +

        The total cost of the purchase. Example: 25.35

        +
        + +
        +

        +

        +

        Recurring charges

        +

        Additionally, in order to set up recurring payments, the WorldPay account must +have ``FuturePay'' enabled, and then you need to use the following parameters.

        +

        The below parameters are used for the ``Regular FuturePay Agreements'' - there is +also ``Limited FuturePay Agreements'' in which a maximum overall charge is set. +For more information, see Repear Billing With FuturePay.

        +
        +
        futurePayType + +
        +

        Should contain the value ``regular'', unless using ``Limited FuturePay Agreements,'' +which will work but is not described here.

        +
        + +
        option + +
        +

        Should contain either 0, 1, or 2. 0 means the payment amount is fixed and +cannot be changed. 1 means the payment is fixed, but can be changed to another +amount at any point. 2 means the payment amount must be set before each +recurring payment.

        +
        + +
        startDate + +
        +

        Value in the format: ``yyyy-mm-dd''. This should be the date on which the first +future payment should be taken. Note that this is _NOT_ and CANNOT be today, +but must be a value in the future. If using option 2, this value must be at +least 2 weeks in the future.

        +
        + +
        startDelayUnit + +
        +

        One digit: 1: day, 2: week, 3: month, 4: year. Only used if startDate is +not set. If using option 2, this value must be at least 2 weeks in the +future.

        +
        + +
        startDelayMult + +
        +

        The actual delay is obtained by multiplying this value by startDelayUnit. So, +to start in three weeks, this would be ``3'', and startDelayUnit would be ``2''. +Again, this is not used if startDate is specified. Must be >= 1 if set.

        +
        + +
        noOfPayments + +
        +

        This number of payments that will be made. Leave as 0 or unset for unlimited.

        +
        + +
        intervalUnit + +
        +

        One digit: 1: day, 2: week, 3: month, 4: year. The unit of interval between +payments. This must be set unless noOfPayments is 1. If using option 1 or +option 2, the minimum interval is 2 weeks.

        +
        + +
        intervalMult + +
        +

        The interval between payments is determined by this value multiplied by +intervalUnit. So, to make payments every 1 month, this would be ``1'', and +intervalUnit would be ``3''. Must be >= 1.

        +
        + +
        normalAmount + +
        +

        This must be set for option 0 and option 1, but cannot be set for option 2.

        +
        + +
        initialAmount + +
        +

        This can be used for option 0 or option 1, but cannot be set for option 2. If +set, this overrides the amount of the first payment.

        +
        + +
        +

        For FuturePay (recurring) payments, you still pass the required fields as +normal, except for the amount field: amount can be passed as 0 or a value - if +a value is specified, this will be treated as an immediate payment. So, for +example, if you wanted to charge someone a monthly subscription of $10 starting +today you would pass the following variables:

        +
        +    instId=1234 # (the merchant's installation reference here)
        +    amount=10
        +    cartId=8456a9264q314 # (Some random ID here that you generate)
        +    currency=USD # (Whatever currency they are charging in goes here)
        +    desc=Subscription For Something Cool # (Description of subscription)
        +    option=0
        +    normalAmount=10
        +    startDelayUnit=3
        +    startDelayMult=1
        +    intervalUnit=3
        +    intervalMult=1
        +

        +

        +

        MD5 signing

        +

        Additionally, using WorldPay's MD5 signature feature is strongly recommended.

        +

        To enable this feature, provide a field ``signatureFields'', containing fields +separated by ``:''. Although any fields can be used, ``amount:currency:cartId'' is +recommended. Then, call:

        +
        +    my $md5 = GT::Payment::Remote::WorldPay::md5_signature(
        +        $password, $amount, $currency, $cartId
        +    );
        +

        $password should be a password provided by the user and known only to the user +and WorldPay. The value returned should be passed as the ``signature'' variable.

        +

        This MD5 protection causes WorldPay to reject any faked payment requests and so +is reasonably secure.

        +

        +

        +

        Postback

        +

        Before WorldPay postback notification can occur, you must instruct the user to +enable the callback facility in the Customer Management System. Additionally, +it is recommended that a proper URL to your CGI be specified there, or else +pass along a ``MC_callback'' variable that points to the script _WITHOUT_ a +leading http:// or https://. (e.g. MC_callback=www.example.com/callback.cgi).

        +

        Note that a WorldPay limitation prevents the callback protocol (http://) from +being changed dynamically - whatever protocol is set for your callback URL in +the Customer Management System will be used with the dynamic callback URL.

        +

        +

        +

        Putting it all together

        +

        The typical way to implement all of this is as follows:

        +
          +
        1. Get necessary merchant information (instId, currency, callback +password, and MD5 password). + +
        2. Once the customer has selected what to purchase, generate a cartId (a +random MD5 hex string works well - but do not use the MD5 signature!), and +generate the MD5 signature. + +
        3. Store the cartId somewhere (i.e. in the database). + +
        4. Make a form with all the necessary fields that +submits to WorldPay. + +
        5. Set up the necessary callbacks (at least on_valid and +on_valid). If using a dedicated CGI script for WorldPay +callbacks, it should just call process(); otherwise, check for the CGI +parameter 'transStatus' and if present, call process(). + +
        6. For a valid payment, do whatever you need to do for a valid payment, +and store some record of the payment having been made (storing at least the +cartId, the transId, and the futurePayId is strongly recommended). Use the CGI +parameter 'cartId' to locate the order (i.e. in the database). It's +recommended that you check Appendix A of the ``Select Junior Integration Guide'' +for all available parameters. + +
        +

        +

        +
        +

        SEE ALSO

        +

        http://support.worldpay.com - WorldPay Knowledge Base, containing many +useful WorldPay manuals and instructions.

        +

        http://support.worldpay.com/kb/integration_guides/junior/integration/help/sjig.html +- Select Junior Integration Guide, from which this documentation and module is +primarily derived.

        +

        http://support.worldpay.com/kb/product_guides/futurepay/repeatbilling.html - +Repeat Billing with FuturePay.

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: WorldPay.pm,v 1.9 2006/08/22 23:03:14 brewt Exp $

        +

        This module is designed for version 4.4 of the Select Junior payment +integration.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins.html new file mode 100644 index 0000000..b7b8319 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins.html @@ -0,0 +1,389 @@ + + + + +GT::Plugins - a plugin interface for Gossamer Threads products. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Plugins - a plugin interface for Gossamer Threads products.

        +

        +

        +
        +

        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);
        +

        +

        +
        +

        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:

        +
          +
        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.

          +
        2. +
        3. +

          Runs any 'PRE' hooks registered in the config file. When using ->dispatch(), +each hook is passed the @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 $PLUGIN->action(STOP) (or GT::Plugins->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 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.

          +
        4. +
        5. +

          Assuming ->action(STOP) has not been called, the method +(->dispatch_method) or code reference (->dispatch) will be called, and its +return value stored.

          +
        6. +
        7. +

          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.

          +
        8. +
        9. +

          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.

          +
        10. +
        +

        +

        +
        +

        SEE ALSO

        +

        Also included as part of the plugin system are some modules for web based tools +to manage plugins:

        +

        the GT::Plugins::Manager manpage - Add, remove and edit plugin files.

        +

        the GT::Plugins::Wizard manpage - Create shell plugins.

        +

        the GT::Plugins::Installer manpage - Used in installing plugins.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins/Installer.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins/Installer.html new file mode 100644 index 0000000..e25c636 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Plugins/Installer.html @@ -0,0 +1,410 @@ + + + + +/tmp/glinks/cgi/admin/GT/Plugins/Installer.pm + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Plugins::Installer

        +

        +

        +
        +

        SYNOPSIS

        +
        +    $mgr->install_hooks('PluginName', ['hook_name', 'PRE|POST', 'code', status]);
        +    $mgr->install_menu('PluginName', ['menu_name', 'menu_url', 'enabled']);
        +    $mgr->install_options('PluginName', ['option_key', 'option_val', 'instructions']);
        +

        +

        +
        +

        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.

        +

        +

        +

        install_hooks

        +

        install_hooks takes as arguments the plugin name and an array of:

        +
        +
        hook_name + +
        +

        The hook you want to override.

        +
        + +
        PRE/POST + +
        +

        Either the string PRE or POST depending on whether the hook should be run +before the main code, or after.

        +
        + +
        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

        +
        + +
        status + +
        +

        Whether or not the hook will be enabled or disabled. For backwards +compatibility, if this option is set to anything but '0' then the hook will be +enabled.

        +
        + +
        +

        install_hooks returns 1 on success, undef on failure with the error +message in $GT::Plugins::error.

        +

        +

        +

        install_menu

        +

        install_menu takes as arguments the plugin name and an array of:

        +
        +
        menu_name + +
        +

        The name that will show up in the admin menu.

        +
        + +
        menu_url + +
        +

        The URL for the menu option.

        +
        + +
        enabled + +
        +

        Either true or false depending on whether the menu option should be shown.

        +
        + +
        +

        install_menu returns 1 on success, undef on failure with the error +message in $GT::Plugins::error.

        +

        +

        +

        install_options

        +

        install_options takes as arguments the plugin name and an array of:

        +
        +
        option_key + +
        +

        This is the key, and is used when accessing the options hash.

        +
        + +
        option_value + +
        +

        This is the default value.

        +
        + +
        instructions + +
        +

        A string instruction users on what the plugin does.

        +
        + +
        +

        install_options returns 1 on success, undef on failure with the error +message in $GT::Plugins::error.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL.html new file mode 100644 index 0000000..70c7f5b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL.html @@ -0,0 +1,588 @@ + + + + +GT::SQL - A database independent perl interface + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL - A database independent perl interface

        +

        +

        +
        +

        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);
        +

        +

        +
        +

        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.

        +

        +

        +

        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 cache => 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 subclass => 0 or subclass => 1 will enable or disable +the ability to subclass any of the objects GT::SQL creates. The default +value is 1, and should not normally be changed.

        +

        GT::SQL has significant amounts of debugging output that can be enabled by +specifying a value of 1 to the debug option. Larger values can be +specified for more detailed debugging output, however a level of 1 is almost +always more than sufficient. The accepted values are as follows:

        +
        +
        Level 0 + +
        +

        This is the default, no debugging information is printed to stderr. All errors +can be obtained in $GT::SQL::error.

        +
        + +
        Level 1 + +
        +

        All queries will be displayed to stderr. This is the recommended value if +query debugging is desired.

        +
        + +
        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.

        +
        + +
        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.

        +
        + +
        +

        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.

        +

        +

        +

        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.

        +
        +
        driver + +
        +

        This needs to be the driver that is being used for the connection. The default +for this is mysql. Driver names are case-insensitive. Available drivers +are:

        +
        +
        +
        MySQL + +
        +

        Driver for MySQL databases. Requires that the DBD::mysql module be installed.

        +
        + +
        Pg + +
        +

        Driver for PostgreSQL databases. Requires that the DBD::Pg module be +installed.

        +
        + +
        MSSQL + +
        +

        Driver for MSSQL 7.0 and above. Requires that the DBD::ODBC module be +installed.

        +
        + +
        Oracle + +
        +

        Driver for Oracle 8 and above. Requires the DBD::Oracle module.

        +
        + +
        +
        host + +
        +

        This will specify the host to connect to. The default, which is acceptable for +most installations, is localhost.

        +
        + +
        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.

        +
        + +
        database + +
        +

        This is the database name to use on the SQL server. This is required to +connect. For MSSQL, this is the Data Source name.

        +
        + +
        PREFIX + +
        +

        This specifies a prefix to use for table names. See the Table Prefixes +section below for more information.

        +
        + +
        +

        +

        +

        Supported Objects

        +

        The following objects can be obtained through a GT::SQL object:

        +
        +
        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 the GT::SQL::Table manpage for more information on how to use a table object.

        +
        + +
        Creator + +
        +

        To create new tables, you need to use a creator. You can get one by calling:

        +
        +
        +
        +    my $creator = $db->creator('new_table');
        +
        +
        +

        where new_table is the name of the table you wish to create. See +the GT::SQL::Creator manpage for more information on how to use a creator object.

        +
        + +
        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 existing_table is the name of the table you wish the modify. See +the GT::SQL::Editor manpage for more information on how to use an editor object.

        +
        + +
        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 +the GT::SQL::Display::HTML manpage for more information on how to use a html object.

        +
        + +
        +

        +

        +

        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 foo to the beginning of every +table name. This means anywhere you access the table bar, the actual table +stored on the SQL server will be foobar. Note that the prefix should not +be included when getting table/creator/editor/etc. objects - the prefix is +handled completely transparently to all public GT::SQL functionality.

        +

        +

        +

        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;
        +

        +

        +
        +

        SEE ALSO

        +

        the GT::SQL::Table manpage

        +

        the GT::SQL::Editor manpage

        +

        the GT::SQL::Creator manpage

        +

        the GT::SQL::Types manpage

        +

        the GT::SQL::Admin manpage

        +

        the GT::SQL::Display::HTML manpage

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Admin.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Admin.html new file mode 100644 index 0000000..be9bcb1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Admin.html @@ -0,0 +1,405 @@ + + + + +GT::SQL::Admin - instant admin for any sql table. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Admin - instant admin for any sql table.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $cgi   = new GT::CGI;
        +    my $db    = new GT::SQL '/path/to/def';
        +    my $admin = new GT::SQL::Admin;
        +    if ($admin->for_me($cgi)) {
        +        $admin->process(db => $db, cgi => $cgi);
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::Admin provides an easy way to build a table/relation +management application. It provides all the HTML and code to +easily:

        +
        +    1. Add records
        +    2. Delete records
        +    3. Modify records
        +    4. Search records
        +    5. Add columns
        +    6. Drop columns
        +    7. Alter table properties
        +    8. Import data
        +    9. Export data
        +

        all in about 6 lines of code.

        +

        +

        +

        Usage

        +

        To use GT::SQL::Admin you need to pass in an existing +the GT::SQL manpage object, and a the GT::CGI manpage object.

        +

        In it's simplest usage, you can simply call:

        +
        +    my $admin = new GT::SQL::Admin;
        +    $admin->process(db => $db, cgi => $cgi);
        +

        and the admin module will figure out what was requested and display +the appropriate screen. There is a $admin->for_me method that will +look to see if the cgi object contains something for the admin +to do, returning 1 if yes, 0 otherwise. You would then do:

        +
        +    my $cgi = new GT::CGI;
        +    my $admin = new GT::SQL::Admin;
        +    if ($admin->for_me($cgi)) {
        +        $admin->process(db => $db, cgi => $cgi);
        +    }
        +

        You can also call any of the methods individually. You can create an +add form like:

        +
        +    $admin->add_form;
        +

        and it will be printed to STDOUT.

        +

        To change the look of a page, you can pass in strings or code refs +to display any of the following items:

        +
        +    start_html
        +    header
        +    start_form
        +    end_form
        +    footer
        +    end_html
        +

        and the admin will use your html/code when displaying. You can also pass +in to process:

        +
        +        record       => 'MyObject'
        +

        and the admin will use that string when displaying titles like 'Add MyObject'. +If you don't specify, it will default to the name of the table.

        +

        +

        +

        Subclassing the admin

        +

        You can enhance the functionality of an admin quite easily. By default +GT::SQL::Admin expects to find a GT::SQL object, a GT::CGI object, and uses +internally a GT::SQL::Display::HTML object for any form/record html +generation.

        +

        Alternatively, you can subclass one or more of the above and use your +own libraries. For instance, if you wanted to expand the form generation, +you could subclass the GT::SQL::Display::HTML object and override the display() +and form() method with your own.

        +

        The admin will pass in a 'mode' to both display and form that will tell +you what it is using the form for. This can be one of:

        +
        +    search_form
        +    search_results
        +    add_form
        +    add_success
        +    delete_search_form
        +    delete_search_results
        +    download_file
        +    modify_search_form
        +    modify_search_results
        +    modify_form
        +    modify_success
        +    modify_multi_search_results
        +    modify_multi_results_norec
        +    modify_multi_result_changed
        +    modify_multi_results_err
        +

        There are also several options that can be passed in. See the +the GT::SQL::Display::HTML manpage module for more information.

        +

        Also be sure to read about subclassing in the GT::SQL manpage.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Admin.pm,v 1.161 2009/05/11 22:57:15 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Condition.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Condition.html new file mode 100644 index 0000000..df62ba8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Condition.html @@ -0,0 +1,392 @@ + + + + +GT::SQL::Condition - Creates complex where clauses + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Condition - Creates complex where clauses

        +

        +

        +
        +

        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;
        +

        +

        +
        +

        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, 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 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 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 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.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Creator.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Creator.html new file mode 100644 index 0000000..7996e89 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Creator.html @@ -0,0 +1,556 @@ + + + + +GT::SQL::Creator - an object to create SQL tables. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Creator - an object to create SQL tables.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $creator = $DB->creator('Newtable');
        +    $creator->cols(
        +        col1 => {
        +            pos => 1
        +            type => 'CHAR',
        +            size => 50
        +        },
        +        col2 => {
        +            pos => 2,
        +            type => 'INT',
        +            not_null => 1
        +        }
        +    );
        +    $creator->pk('col2');
        +    $creator->ai('col2');
        +    $creator->create or die "Unable to create: $GT::SQL::error";
        +

        +

        +
        +

        DESCRIPTION

        +

        A creator object is used to build new SQL tables.

        +

        To get a new creator object, you need to call creator() from an existing +GT::SQL object.

        +

        The object that is returned has methods to set up your table. You will need to +call this method for each table you want to create.

        +
        +    $creator = $obj->creator($table);
        +

        You must pass in the name of the table you want to create. This means if you +have a table named MyTable you must call ->creator with 'MyTable' +as the argument.

        +
        +    $creator = $obj->creator('MyTable');
        +

        From this point you can call create methods on your creator object to define +and create your table.

        +

        +

        +

        cols

        +

        cols is used to define the columns that will be in the new table by setting +properties such as the type, whether it allows null values, unsigned etc.

        +

        For detailed information on the types and options accepted, please see +the GT::SQL::Types manpage. The following describes the options accepted that do not +directly affect the underlying database:

        +
        +
        values + +
        +

        This specifies the values for the ENUM column type. If you are using an +ENUM this must be set. The value for this should be an array reference of +the possible values for the ENUM column. The values in the array that is +passed in will be quoted by DBI's quote method.

        +
        + +
        regex + +
        +

        This is a regex that the value must pass before being inserted +into the database.

        +
        + +
        form_display + +
        +

        This is a ``pretty name'' that will be used by the HTML module +for creating attractive forms automatically.

        +
        + +
        form_size + +
        +

        This is the form field length to be used by the HTML module.

        +
        + +
        form_type + +
        +

        This is the type of form to use by the HTML module: select, checkbox +radio, text, textarea or hidden.

        +
        + +
        form_names + +
        +

        This is for multi select or checkboxes and is an array ref of names +that get displayed.

        +
        + +
        form_values + +
        +

        This is for multi select or checkboxes and is an array ref of the +actual values that will be stored in the database.

        +
        + +
        time_check + +
        +

        This is only useful for TIMESTAMP fields. If set to 1, the module +will not allow you to update a record which has an older timestamp +then what is in the database. This is very helpful for protecting +against multiple updates.

        +
        + +
        weight + +
        +

        By giving an item a weight, GT::SQL will maintain a search index +table, and use that search index table when called using query. +This is only useful for indexing large text fields and should not +be used normally. The higher the weight, the more influence that +column will have on the result. So if a Title was set to weight +3 and a Description to weight 1, then when doing a search, a match +in the title would make the result appear before a match in the +description.

        +
        + +
        +

        So an example would look like:

        +
        +    $creator->cols(
        +        $col1 => {
        +            type     => 'ENUM',
        +            values   => ['val1', 'val2' ... ],
        +            not_null => 1
        +        },
        +        $col2 => {
        +            ...
        +        }
        +    );
        +

        Sets the relations columns as specified via method +parameters. The only required key for the has is type. +However some column types require other values be set +such as ENUM requires you specify the values.

        +

        +

        +

        pk

        +

        pk lets you specify the primary keys for the current table. +This method can be called with an array of primary key columns +in which case all the specified column names in the array will +make up the primary keys. If you call it with a single scalar +value this is assumed to be the primary key for the table.

        +
        +    $creator->pk($field1, $field2, ...);
        +

        +

        +

        ai

        +

        This specifies the auto increment column for the current table. +There can be only one auto increment column per table, it must +be a numeric type, it must be not null and it must be the +primary key. This limitation is checked when you call create. +If it is not a numeric column type you will get a fatal error +when you call create. If any of the other limitations fail +the creator class will correct.

        +

        +

        +

        index

        +

        index allows you to specify the name and the columns for you +table indexes.

        +

        There are two ways to call this method.

        +

        You can set up all your indexes at once by calling it with +hash reference like this:

        +
        +    $creator->index({
        +        $index1 => [field1, field2],
        +        $index2 => [field3, field4]
        +    });
        +

        The keys to this hash reference are the index names and +the values are an array reference containing the columns +that are part of the named index. The order for these +columns are maintained during the create.

        +

        You can also pass in one index at a time like this;

        +
        +    $creator->index($index_name, $col1, ..., $coln);
        +

        The first argument is the name of the index and all the +rest are treated as columns that are part of this index. +Again the order of the columns are maintained.

        +

        +

        +

        unique

        +

        The unique method allows you to specify the unique +indexes for the current table. This method takes the +same arguments as the index method.

        +

        +

        +

        fk

        +

        fk allows you to specify foreign key relations for your +tables. You CAN NOT specify foreign keys for tables that +have not been created yet. There are two ways to pass in +arguments to fk. The first way is passing in a hash reference.

        +
        +    $creator->fk({
        +        $FOREIGN_TABLE_NAME =>
        +        {
        +            $LOCAL_TABLE_COL_1 => $FOREIGN_TABLE_COL_1,
        +            ...
        +            $LOCAL_TABLE_COL_n => $FOREIGN_TABLE_COL_n
        +        }
        +    });
        +

        The keys to the hash are the names of the tables you are relating to. +The values are a hash reference that contain the name of the current +tables columns as the keys and the name of the foreign tables columns +that we are relating to as the values.

        +

        You cannot relate fields to your self. You also need to be careful +not to create circular references. This is checked when you call this +method. If there is a circular reference detected you will receive a +fatal error.

        +

        Foreign keys currently effect selects only.

        +

        +

        +

        search_driver

        +

        This affects how the weighted records are indexed. By default the +system will attempt to use best driver for the DBMS. However, if +you'd like to force the indexing system to an alternative type, such +as for MYSQL you can use this.

        +

        * note: though the MYSQL driver is faster, the internal indexing system +has better support for phrase searching and keyword searching.

        +

        To set the driver, call search_driver with the appropriate driver +name. The following example will force the system into using the +internally implemented indexing scheme.

        +
        +    $creator->search_driver('INTERNAL');
        +

        Currently, the only other valid option is ``MYSQL''.

        +

        -note-

        +

        The MYSQL driver occasionally behaves oddly with a small number of +records. In that case, set the search scheme to ``INTERNAL''.

        +

        +

        +

        create

        +

        This is the method you call to create your table after you have specified +all your table definitions. Several checks are made when this method is +called to ensure the table is created correctly.

        +

        One of the things that is done is checking to see that the table you are +trying to create does not exist. If the table does exist create will +return undefined and set the error in $GT::SQL::error.

        +

        You can specify to have create drop the table by passing in ``force''.

        +
        +    $creator->create('force');
        +

        -or-

        +
        +    $creator->create;
        +

        create returns true on success and undef on failure.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Editor.html new file mode 100644 index 0000000..83a8bed --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Editor.html @@ -0,0 +1,496 @@ + + + + +GT::SQL::Editor - an interface to modify an SQL table. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Editor - an interface to modify an SQL table.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $editor = $DB->editor('Table');
        +    $editor->add_col(Foo => { size => 20, type => 'int' });
        +    $editor->export_data('/tmp/foo.txt');
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::Editor is an easy way to do a lot of table maintenance +functions like:

        +

        * Adding columns +* Dropping columns +* Changing columns +* Altering keys +* Importing data +* Dropping data

        +

        To get an editor object, you simply call editor from a +GT::SQL object, and specify the tablename you want to edit:

        +
        +    $editor = $db->editor('TableName');
        +

        Note: You can not use Editor with relations, only tables.

        +

        +

        +

        add_col

        +

        This method allows you to add a column to the current table. +All attributes for the column are passed in a single hash.

        +
        +    $editor->add_col($col_name, 
        +                        { 
        +                            size => 20, 
        +                            type => 'int',
        +                            view_size => 20, 
        +                            form_display => "my col", 
        +                            regex => 'myregex' 
        +                        }
        +                    );
        +

        The same rules apply to this method that apply when you +define a column for creating a table. You must specify the +type.

        +

        +

        +

        drop_col

        +

        This method drops a column from the current table. Checks +are made to ensure the column is not linked to by a foreign +key relation.

        +
        +    $editor->drop_col($col_name);
        +

        -or-

        +
        +    $editor->drop_col($col_name, "remove");
        +

        If you just specify the column name drop_col will check if +the column is referenced in a foreign key relation. If it +is drop_col will return undef and set the error message in +$GT::SQL::error. If it is not the column will be dropped.

        +

        If you specify ``remove'' drop_col will remove all foreign +key relations that point to the specified column.

        +

        If the specified column is itself a foreign key relation, the relation will be +dropped.

        +

        +

        +

        alter_col

        +

        This allows you to make changes to a columns type, null status, +etc..

        +
        +    $editor->alter_col($column_name,
        +                                { 
        +                                    size => 20, 
        +                                    type => 'int' 
        +                                });
        +

        The first argument is the column name the second is the definitions. +The column definitions are exactly the same as the column +definitions from the create. The type must be specified.

        +

        You can not add attributes to the column in this way. +You must specify the original definitions along with the +changes you need to make.

        +

        +

        +

        add_unique

        +

        This allows you to add a unique index to the current table. +If the name of the unique index is the same as another +index you add_unique will return undef and set the error +in $GT::SQL::error.

        +
        +    $editor->add_unique($index_name => [ $field1, $field2 .. ]);
        +

        The name of the new index is the first argument. The second argument +is an array reference containing the columns that will be indexed. +The order of the columns are maintained for the unique index. +If you specify an index that has data in it that is not unique +(yes we do a select on the database) add_unique will return +an error and set the error in $GT::SQL::error.

        +

        +

        +

        drop_unique

        +

        This method allows you to drop a unique index for the current +table. If the unique index does not exist drop_unique will +return undef and set the error in $GT::SQL::error. drop_unique +will also check to make sure dropping the unique index will not +cause problems for the database structure. If dropping the unique +index will cause a problem drop_unique will return undef and set +the error in $GT::SQL::error.

        +
        +    $editor->drop_unique($index_name);
        +

        $index_name should be the name of the unique index to drop.

        +

        +

        +

        add_index

        +

        This takes the same arguments as add_unique and return the same thing. +The only difference is add_index has no reason to check the content of +the current table because indexes are not unique. unique indexes are :)

        +
        +    $editor->add_index($index_name => [ $field1, $field2 .. ]);
        +

        +

        +

        drop_index

        +

        This method drops the specified index from the current table. +drop_index will check to make sure no problems are caused from +dropping the index. If there are drop_index will return undef +and set the error in $GT::SQL::error.

        +
        +    $editor->drop_index($index_name);
        +

        $index_name should be the name of the index to drop.

        +

        +

        +

        add_pk

        +

        This method allows you to add a primary key to the current +database.

        +
        +    $editor->add_pk($field1, $field2, ...);
        +

        If there is already a primary key in the database add_pk +will drop the key and add the this new one. The table +will be check to make sure this change does not create problems +for the table. I problem is auto increment not being the primary +key anymore. If there is a problem this function returns undef +and stores the error in $GT::SQL::error.

        +

        +

        +

        drop_pk

        +

        This method drops the current primary key. If there is no primary +key to drop it returns undef and sets the error in $GT::SQL::error.

        +
        +    $editor->drop_pk;
        +

        If dropping the primary key will cause problems for the database +this method will return undef and set the error in $GT::SQL::error.

        +

        +

        +

        add_fk

        +

        This method allows you to add foreign key relations to the current +table.

        +
        +    $editor->add_fk($RELATION_NAME, { $SOURCE_FIELD_1 => $TARGET_FIELD });
        +

        You can not link your foreign key to tables that do not exist. Also the +columns types and lengths for the two columns must be the same. +Circularity is not allowed either. That is a set of foreign keys can not +end up pointing back at the same table they started at. All of these things +are checked when this is added. If anything does not match this method returns +undef and sets the error in $GT::SQL::error.

        +

        +

        +

        drop_fk

        +

        This method drops the specified foreign key relation.

        +
        +    $editor->drop_fk($table);
        +

        $table should be the name of the foreign table the foreign +key points to.

        +

        +

        +

        drop_table

        +

        This method drops the current table. If there are any foreign keys +pointing to this table this method will fail and return undef. The error +will be set in $GT::SQL::error.

        +
        +    $editor->drop_table;
        +

        -or-

        +
        +    $editor->drop_table("remove");
        +

        If the first argument to this method is remove it will remove all +the foreign key relations that point to this table.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/File.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/File.html new file mode 100644 index 0000000..c5c5247 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/File.html @@ -0,0 +1,407 @@ + + + + +GT::SQL::File - adds file upload and download abilities to GT::SQL + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::File - adds file upload and download abilities to GT::SQL

        +

        GT::SQL::File::Fh - basic file object

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::File is not created directly by the user. This module is an +internal module for GT::SQL to provide the abilty to upload/download +files into a database column (or so it seems).

        +

        GT::SQL::File::Fh is often accessed by the user as well as created +by the user whenever the user wants to store a file in the database.

        +

        +

        +

        Creating a new FILE Column

        +

        When a new table is created or a column is converted into 'FILE' +type, two things are created. First a column of type text which will +save the name of the file that is being stored. Secondly, a +piggy-back table will be greated under the name +``parent_table_name_File''. This new table will store the location of +the uploaded/stored file and various associated file attributes.

        +

        To create a new file table, include a column something like the +following.

        +
        +    File_Col_Name => {
        +
        +                # common parameters
        +                       pos  => 2, 
        +                       type => 'FILE',
        +
        +                # location of the directory where
        +                # all the files should be saved
        +                       file_save_in => '/tmp',
        +
        +                # the method all the files are saved
        +                # 'hashed', or 'simple'
        +                #
        +                # Defaults to hashed, and stores files in:
        +                #   file_save_in/hashed_letter/ID
        +                # Simple stores files in:
        +                #   file_save_in/ID_OwnName.OwnExt
        +                       file_save_scheme => 'hashed',
        +                     } ...
        +

        +

        +

        Inserting into the Column

        +

        Once you have the table created, to insert:

        +
        +    # Include all the modules
        +    use GT::SQL;
        +    use GT::SQL::File;
        +    
        +    # First create a file object pointing to the file
        +    $f = GT::SQL::File->open('/path/to/file.txt');
        +    
        +    # Then create a table object
        +    $DB = GT::SQL->new('path/to/defs');
        +    $tbl = $DB->table();
        +    
        +    # Create the record
        +    # the file field can also be GT::CGI::Fh type
        +    $rec = {
        +        File_Column => $f,
        +        # ... and all the other columns
        +    };
        +

        # optionally, if you know the path to the file, you can provide +# a scalar ref of the path and the module will autoload +# the values +# simple scalar values will be dropped + $rec = { + File_Column => \``/path/to/file.txt'' + # ... and all the other columns + }; +

        +
        +
        +    # Then to store the file
        +    $id = $tbl->add( $rec );
        +

        +

        +

        Retreiving from Column

        +

        When a file has been stored. A standard select will only return +the name of the file.

        +

        To get a filehandle, taking the previous example, if we know the +unique id, you can do the following.

        +
        +    $fh = $tbl->file_info( 'File_Column', $id );
        +

        You can use this file handle just like any other, however hidden +behind are special functions that can be used as follows:

        +
        +    print "Content-type: ", $fh->File_MimeType(), "\n\n";
        +    print <$fh>;
        +

        The following is a partial list of special functions you may access.

        +
        + 
        +    Method             Returns
        +    ------             -------
        +    File_Name          the basic filename
        +    File_Directory     path to the file
        +    File_MimeType      mimetype of the file
        +    File_Size          site of the file
        +    File_RelativePath  the permuted file and directory without root
        +    File_URL           if possible, the URL to the requested file
        +    File_RelativeURL   the relative URL to the requested file
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: File.pm,v 1.69 2009/03/10 20:18:49 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Relation.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Relation.html new file mode 100644 index 0000000..1f61368 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Relation.html @@ -0,0 +1,603 @@ + + + + +GT::SQL::Relation - manage multiple table joins + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Relation - manage multiple table joins

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $relation = $DB->table('Company', 'Employees');
        +    my $sth = $relation->select( {
        +                    Company.Name => 'Gossamer Threads',
        +                    Employees.Name => 'Alex Krohn'
        +                }, ['Employees.Salary', 'Company.City'] );
        +    my ($salary, $city) = $sth->fetchrow_array;
        +    print "Alex works in $city and earns $salary!\n";
        +

        +

        +
        +

        DESCRIPTION

        +

        This module aims at emulating a set of tables that are related to each other +via the use of foreign keys just as if it was one big table.

        +

        The module interface should be as compatible as possible with GT::SQL::Table, +thus you should be familiar with GT::SQL::Table before even reading this.

        +

        This documentation explains the differences between GT::SQL::Relation and +GT::SQL::Table and how the module internally works as well.

        +

        +

        +

        How it works

        +

        GT::SQL supports the concept of foreign keys (also known as external +references). Basically, two tables that are linked together using external +references can look like that:

        +
        +    .-------------.      .---------.
        +    | EMPLOYEE    |      | COMPANY |
        +    `-------------'      `---------'
        +    |  ID         |   .--->ID      |
        +    |  COMPANY_ID ----'  | NAME    |
        +    |  NAME       |      `---------'
        +    |  SALARY     |
        +    `-------------'
        +

        In this example, the COMPANY_ID attribute relates the fact that a an EMPLOYEE +belongs to such or such COMPANY.

        +

        Utilizing a Relation object can make these tables look like that:

        +
        +    .----------------------.
        +    | EMPLOYEE-COMPANY     |
        +    `----------------------'
        +    |  EMPLOYEE.ID         |
        +    |  EMPLOYEE.COMPANY_ID |
        +    |  EMPLOYEE.NAME       |
        +    |  EMPLOYEE.SALARY     |
        +    |  COMPANY.NAME        |
        +    `----------------------'
        +

        The first thing that can be seen from there is that COMPANY.ID has disappeared +from this ``Virtual'' table.

        +

        Indeed, as for a given ``joined'' record this value must be the same in both +tables, representing the values twice would have been a useless source of +confusion.

        +

        +

        +

        SELECT statements

        +

        Selecting from a Relation object is pretty simple using the GT::SQL module. As +the interface is (almost) the same as the GT::SQL::Table manpage, the GT::SQL wrapper +returns Table or Relation objects depending on the arguments that are passed to +table.

        +
        +    # This gives me a GT::SQL::Table object for
        +    # the EMPLOYEE table.
        +    my $emp = $sql->table('EMPLOYEE');
        +
        +    # This gives me a GT::SQL::Relation object for
        +    # the relation EMPLOYEE-COMPANY tables
        +    my $emp_cmp = $sql->table('EMPLOYEE','COMPANY');
        +

        From there, performing a select is pretty simple:

        +
        +    # select all the people from a real cool company
        +    my $sth = $emp_cmp->select( { COMPANY.NAME => "Gossamer Threads" } )
        +

        Internally, the generated SQL query would look like:

        +
        +    SELECT EMPLOYEE.ID, EMPLOYEE.COMPANY_ID, EMPLOYEE.NAME
        +       EMPLOYEE.SALARY, COMPANY.NAME
        +    FROM   EMPLOYEE, COMPANY
        +    WHERE  COMPANY.NAME = 'Gossamer Threads' AND
        +           EMPLOYEE.COMPANY_ID = COMPANY.ID
        +

        Note that the join condition is computed and automatically appended at the end +of the query, so you do not have to worry about this.

        +

        +

        +

        SELECT options

        +

        The select options for relation are similar to that of table, you have +select_options() which will be set for the next query done. Example:

        +
        +    $relation->select_options("LIMIT 10");
        +

        This would append 'LIMIT 10' to your next select query. Another useful thing +is join_on(). join_on() allows you to specify the FK relation for the nextr +select. This overrides what is in the def files. It is useful for allowing you +to have one table which will be join differently depending on what you are +doing. The argument to this are the same as to fk(). +Example:

        +
        +    $relation->join_on( remote_table => { local_column => remote_column } );
        +

        The FK relation will be changed to this the next time you call select() but +then it will be cleared.

        +

        +

        +

        Listing the relation columns

        +

        * As previously said, the cols() method when invoked on a GT::SQL::Relation +object does not return all the columns, removing the duplicate external +references. So, how does it decides which column to keep and which one to +return?

        +

        In the EMPLOYEE-COMPANY example we have the constraint +EMPLOYEE.COMPANY_ID => COMPANY.ID and it keeps COMPANY_ID, i.e. the foreign key +instead of the key itself.

        +

        +

        +

        Relation primary key

        +

        * The pk() method has to return the table primary key. The property of a primary +key is that it is a non-null unique record identifier. When pk() is invoked on +a Relation object, this base definition is applied to construct the object +primary key.

        +

        To find a unique set of fields that makes a good primary key for a Relation +object, the following, simple algorithm is used:

        +
        +    .                                                        .
        +    . for each table                                         .
        +    .   if the table is not referenced by another table that .
        +    .   is in the current relation                           .
        +    .     do                                                 .
        +    .       append the current table's primary key fields to .
        +    .       the Relation primary key fields                  .
        +    .     end-do                                             .
        +    .   end-if                                               .
        +    . end-for                                                .
        +    .                                                        .
        +

        This algorithm selects all the tables that represent the ``many'' in one-to-many +relations, and for all these tables add a list of fields which ensure a record +uniqueness.

        +

        +

        +

        Foreign keys management

        +

        * When invoked on a GT::SQL::Table object, the fk() method returns a hash which +has the following general structure:

        +
        +    {
        +      target_table_1 => {
        +                          source_col_1 => target_col_1,
        +                          source_col_2 => target_col_2
        +                        },
        +      target_table_2 => {
        +                          source_col_1 => target_col_1
        +            }
        +    }
        +

        The GT::SQL::Relation module returns a hash which has the same structure. The +only difference is that it does not returns the external references which are +managed internally.

        +

        This is done for two reasons: As one field is removed from a Relation table, it +would not have been very logical to return a structure that point to +non-existent fields.

        +

        Moreover, these internal references from the ``Relation'' point of view have +nothing to do with the external world and thus should not be shown.

        +

        (i.e. EMPLOYEE.COMPANY_ID |===> COMPANY.ID would not count in our example)

        +

        +

        +

        Inserting data

        +

        The interface for inserting data in a Relation is the same as the one that is +being used for Table. However, because rows are being inserted in a relation +one-to-many, things internally work a bit differently.

        +

        The Relation insert() method takes an optional argument, which can be +'complete' or 'abort' (default being complete).

        +

        insert() splits the relation columns into separate records that can be inserted +in a single table. However, some of the records may exist already!

        +

        for example, if we perform:

        +
        +    $sql = shift; # our GT::SQL object
        +    $rel = $sql->table(qw/EMPLOYEE COMPANY/);
        +    $rel->insert({
        +        'EMPLOYEE.NAME'   => $your_name,
        +        'EMPLOYEE.SALARY' => $big_buck,
        +        'COMPANY.NAME'    => "Gossamer Threads"
        +    });
        +

        Obviously the company ``Gossamer Threads'' already exists, but you were not in +the ``EMPLOYEE'' table. Thus, when 'complete' is specified (it is the default +option), the program will not complain if a record to insert already exists but +just warns and continue the insertion work.

        +

        In other words, Gossamer Threads exists already and it will not be inserted +twice, but the employee will still be inserted and will belong to this company.

        +

        On the other hand, if you specify ``abort'', then no data is inserted if a +record that has to be inserted would trigger an error in GT::SQL::Table.

        +

        This feature can be useful if you want to insert a relation record assuming +that none of the entities that you specify should exist.

        +

        +

        +

        Deleting data

        +

        Deleting data from a Relation object works using the following pattern:

        +
        +    .                                                        .
        +    . for each row that matches the delete condition         .
        +    . do                                                     .
        +    .   split the row in table-based records                 .
        +    .   for each table that contains foreing keys from the   .
        +    .       current relation object                          .
        +    .   do                                                   .
        +    .     delete the record                                  .
        +    .   end-do                                               .
        +    .                                                        .
        +    .   for each table that is being referenced by another   .
        +    .       table in the current relation object             .
        +    .   do                                                   .
        +    .     delete the record unless there exists              .
        +    .     some "referencing" data.                           .
        +    .   end-do                                               .
        +    .                                                        .
        +

        As I feel that this explanation is probably very confusing, let us see how it +works using our classical example (The salary column has been removed).

        +
        +  .-------------------------------------------------------------.
        +  | EMPLOYEE.ID | COMPANY_ID | EMPLOYEE.NAME | COMPANY.NAME     |
        +  `-------------------------------------------------------------'
        +  | 1           | 1          | Alex          | Gossamer Threads |
        +  |-------------|------------|---------------|------------------|
        +  | 2           | 1          | Scott         | Gossamer Threads |
        +  |-------------|------------|---------------|------------------|
        +  | 3           | 1          | Aki           | Gossamer Threads |
        +  `-------------------------------------------------------------'
        +

        Now let us say that we do the following:

        +
        +  # remove all the crazy geeks
        +  $relation->delete({ 'EMPLOYEE.NAME' => 'Scott' });
        +

        This will remove ``Scott'' from the EMPLOYEE table, but of course +Gossamer Threads will not be deleted because there still exists Alex and Aki +that would reference it.

        +

        Now if we do:

        +
        +  $relation->delete({ 'COMPANY.NAME' => 'Gossamer Threads' });
        +

        or even

        +
        +  my $condition = new GT::SQL::Condition;
        +  $condition->add(qw/EMPLOYEE.NAME LIKE %/);
        +  $relation->delete($condition);
        +

        Then we have generated a condition that matches all the employees, this means +that when the last record will be deleted, then the company Gossamer Threads +will have no more employees and therefore will be deleted.

        +

        (Yeah, well, this is for the purpose of this example, of course this will never +happen in real life :) )

        +

        +

        +

        Updating records

        +

        Currently, there exists a limitation on updating records in a Relation, which +is that only the records that represent the ``many'' part of the Relation are +updated.

        +

        The way it proceeds to perform the update is pretty simple:

        +
        +    .                                                        .
        +    . for each row that matches the update condition         .
        +    . do                                                     .
        +    .   split the row in table-based records                 .
        +    .   for each table that contains foreing keys from the   .
        +    .       current relation object                          .
        +    .   do                                                   .
        +    .     update the record                                  .
        +    .   end-do                                               .
        +    .                                                        .
        +

        That means that this will work:

        +
        +  # SALARY being a property of EMPLOYEE, it will be updated
        +  # because EMPLOYEE references COMPANY and therefore is a
        +  # "many"
        +  $relation->update({ SALARY => $big_bill },
        +                    { 'COMPANY.NAME' => 'Gossamer Threads' });
        +
        +  # nope, you cannot use Relation to update the COMPANY table that
        +  # way, this will not do anything.
        +  $relation->update({ 'COMPANY.NAME' => 'New_Name' },
        +                    { 'COMPANY.NAME' => 'Gossamer Threads' });
        +

        Who would like to change such a great name anyway ?

        +

        +

        +

        Selecting Records

        +

        Select behaves exactly like the GT::SQL::Table manpage select. The only difference is +the ability to specify LEFT JOINs. For instance, if you want to see a list of +Employees who don't belong to a company, you can do:

        +
        +    my $relation = $DB->table('Employees', 'Company');
        +    my $cond = GT::SQL::Condition->new('Company.ID', 'IS', \'NULL');
        +    my $sth = $relation->select('left_join', $cond);
        +

        The order of tables specified in the relation constructor is important!

        +

        In selecting columns, calling functions utilizing fully qualified column names +will cause GT::SQL::Relation to fail. Simply turn the values into references +like below.

        +
        +    my $sth = $relation->select("MIN(Company.ID)"); # will fail
        +
        +    my $sth = $relation->select(\"MIN(Company.ID)"); # will work
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Search.html new file mode 100644 index 0000000..987294f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Search.html @@ -0,0 +1,797 @@ + + + + +GT::SQL::Search - internal driver for searching + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Search - internal driver for searching

        +

        +

        +
        +

        SYNOPSIS

        +

        This implements the query string based searching scheme for GT::SQL. Driver +based, it is designed to take advantage of the different indexing schemes +available on different database engines.

        +

        +

        +
        +

        DESCRIPTION

        +

        Instead of describing how Search.pm is interfaced* this will describe how a +driver should be structured and how a new driver can be implemented.

        +

        * as it is never accessed directly by the programmer as it was designed to be +called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth

        +

        +

        +

        Drivers

        +

        A driver has two parts. The Indexer and the Search packages are the most +important. Howserver, for any driver in the search, there must exist a directory +with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES +for Postgres. Within each driver directory, The Indexer and Search portions of +the driver contains all the information required for initializing the database +table and searching the database.

        +

        The Indexing package of the driver handles all the data that is manipulated in +the database and also the initializes and the database for indexing.

        +

        The Search package handles the queries and retrieves results for the eventual +consumption by the calling program.

        +

        Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base +and operate by overriding certain key functions.

        +

        The next few sections will cover how to create a search driver, and assumes a +fair bit of familiarity with GT::SQL.

        +

        +

        +

        Structure of an Indexing Driver

        +

        The following is an absolutely simple skeleton driver that does nothing and but +called ``CUSTOM''. Found in the CUSTOM directory, this is the search package, and +would be call Search.pm in the GT/SQL/Search/CUSTOM library directory.

        +
        +    package GT::SQL::Search::CUSTOM::Search;
        +    #------------------------------------------
        +        use strict;
        +        use vars qw/ @ISA /;
        +        use GT::SQL::Search::Base::Search;
        +        @ISA = qw( GT::SQL::Search::Base::Search );
        +    
        +    sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) };
        +    
        +    # overrides would go here
        +    
        +    1;
        +

        For the indexer, another file, Indexer.pm would be found in the +GT/SQL/Search/CUSTOM directory.

        +
        +    package GT::SQL::Search::CUSTOM::Indexer;
        +    #------------------------------------------
        +    
        +        use strict;
        +        use vars qw/ @ISA /;
        +        use GT::SQL::Search::Base;
        +        @ISA = qw/ GT::SQL::Search::Base::Indexer /;
        +    
        +    sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
        +    
        +    # overrides would go here
        +    
        +    1;
        +

        The almost empty subs that immediately return with a value are functions that +can be overridden to do special tasks. More will be detailed later.

        +

        The Driver has been split into two packages. The original package name, +GT::SQL::Search::Nothing, houses the Search package. +GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system. +``::Indexer'' must be appended to the orginial search name for the indexer.

        +

        Each of the override functions are triggered at points just before and after a +major event occurs in GT::SQL. Depending on the type of actions you require, you +pick and chose which events you'd like your driver to attach to.

        +

        +

        +

        Structure of Indexing Driver

        +

        The Indexer is responsible for creating all the indexes, maintaining them and +when the table is dropped, removing all the associated indexes.

        +

        The following header must be defined for the Indexer. +GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from.

        +
        +    package GT::SQL::Search::CUSTOM::Indexer;
        +    #------------------------------------------
        +    
        +        use strict;
        +        use vars qw/ @ISA /;
        +        use GT::Base;
        +        use GT::SQL::Search::Base::Indexer;
        +        @ISA = qw/ GT::SQL::Search::Base::Indexer /;
        +

        In addition to the header, the following function must be defined. +GT::SQL::Search::Driver::Indexer::load creates the new object and allows for +special preinitialization that must occur. You can also create another driver +silently (such as defaulting to INTERNAL after a version check fails).

        +
        +    sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
        +

        Finally, there are the overrides. None of the override functions need be defined +in your driver. Any calls made to undefined methods will silently fallback to +the superclass driver's methods. When a method has been overridden, the function +must return a true value when it is successful, otherwise the action will fail +and an error generated.

        +

        Whenever a object is created it will receive one property $self->{table} which +is the table that is being worked upon. This property is available in all the +method calls and is required for methods such as _create_table and +_drop_search_driver methods.

        +

        When a table is first created or when a table is destroyed the following two +functions are called. They are not passed any special values, however, these are +all class methods and $self->{table} will be a reference to the current table in +use.

        +

        This set of overrides are used by GT::SQL::Creator when the ::create method is +called. They are called just prior and then after the create table sql query has +been executed.

        +
        +
        pre_create_table + +
        post_create_table + +
        +

        These functions receive no special parameters. They will receive the data to the +table in the $self->{table} property.

        +
        + +
        +

        This next set of functions take place in GT::SQL::Editor.

        +
        +
        drop_search_driver + +
        +

        This method receives no special parameters but is responsible for removing all +indexes and ``things'' associated with the indexing schema.

        +
        + +
        add_search_driver + +
        +

        Receives no extra parameters. Creates all indexes and does all actions required +to initialize indexing scheme.

        +
        + +
        pre_add_column + +
        post_add_column + +
        +

        The previous two functions are called just before and after a new column is +added.

        +
        +
        +

        pre_add_column accepts $name (of column), $col (hashref of column attributes). +The method will only be called if the column has a weight associated with it. +The function must return a non-zero value if successful. Note that the returned +value will be passed into the post_add_column so temporary values can be passed +through if required.

        +
        +
        +

        post_add_column accepts $name (of column), $col (hashref of column attributes), +$results (of pre_add_column). This method is called just after the column has +been inserted into the database.

        +
        + +
        pre_delete_column + +
        post_delete_column + +
        +

        These previous functions are called just before and after the sql for a old +column is deleted. They must remove all objects and ``things'' associated with a +particular column's index.

        +
        +
        +

        pre_delete_column accepts $name (of column), $col (hashref of column +attributes). The method will only be called if the column has a weight +associated with it. The function must return a non-zero value if successful. +Note that the returned value will be passed into the post_delete_column so +temporary values can be passed through if required.

        +
        +
        +

        post_delete_column accepts $name (of column), $col (hashref of column +attributes), $results (of pre_add_column). This method is called just after the +column has been dropped from the database.

        +
        + +
        pre_drop_table + +
        post_drop_table + +
        +

        The two previous methods are used before and after the table is dropped. The +methods must remove any tables or ``things'' related to indexing from the table.

        +
        +
        +

        pre_drop_table receives no arguments. It can find a copy of the current table +and columns associated in $self->{table}.

        +
        +
        +

        post_drop_table receives one argument, which is the result of the +pre_drop_table.

        +
        + +
        +

        The following set of functions take place in GT::SQL::Table

        +
        +
        pre_add_record + +
        post_add_record + +
        +

        Called just before and after an insert occurs. These functions take the record +and indexes them as required.

        +
        +
        +

        pre_add_record will receive one argument, $rec, hashref, which is the record +that will be inserted into the database. Table information can be found by +accessing $self->{table} Much like the other functions, on success the result +will be cached and fed into the post_add_record function.

        +
        +
        +

        post_add_record receives $rec, a hashref to describing the new result, the $sth +of the insert query, and the result of the pre_add_record method. The result +from $sth->insert_id if there is a ai field will be the new unique primary key.

        +
        + +
        pre_update_record + +
        post_update_record + +
        +

        Intercepts the update request before and just after the sql query is executed. +This override has the potential of being rather messy. More than one record can +be modified in this action and the indexer must work a lot to ensure the +database is up to snuff.

        +
        +
        +

        pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is +a hashref containing the new values that must be set, and $where_cond is a +GT::SQL::Condition object selecting records to update. The result once again, is +cached and if undef is considered an error.

        +
        +
        +

        post_update_record takes the same parameters as pre_update_record, except one +extra paremeter, the result of pre_update_record.

        +
        + +
        pre_delete_record + +
        post_delete_record + +
        +

        Called just before and after the deletion request for records are called.

        +
        +
        +

        pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object +telling which records to delete. The results of this method are passed to +post_delete_record.

        +
        +
        +

        post_delete_record, has one addition parameter to pre_delete_record and like +most post_ methods, is the result of the pre_delete_record method.

        +
        + +
        pre_delete_all_records + +
        post_delete_all_records + +
        +

        These two functions are quite simple, but they are different from drop search +driver in that though the records are all dropped, the framework for all the +indexing is not dropped as well.

        +
        +
        +

        Neither function is passed any special data, except for post_delete_all_records +which receives the rsults of the pre_delete_all_records method.

        +
        + +
        reindex_all + +
        +

        This function is sometimes called by the user to refresh the index. The +motivation for this, in the case of the INTERNAL driver, is sometimes due to +outside manipulation of the database tables, the index can become +non-representative of the data in the tables. This method is to force the +indexing system to fix errors that have passed.

        +
        + +
        ok + +
        +

        This function is called by GT::SQL::Search as a package method, +GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object +reference. What this function must do is to return a true or false value that +tells the search system if this driver can be used. The MYSQL driver has a good +example for this, it tests to ensure that the mysql database system version is +at least 3.23.23.

        +
        + +
        +

        +

        +

        Structure of a Search Driver

        +

        The Searcher is responsible for only one thing, to return results from a query +search. You can override the parser, however, subclassing the following methods +will have full parsing for all things such as +/-, string parsing and substring +matching.

        +

        The structures passed into the methods get a little complicated so beware!

        +

        ALL the following functions receive two parameters, the first is a search +parameters detailing the words/phrases to search for, the second parameter is +the current result set of IDs => scores.

        +

        There are two types of search parameters, one for words and the other for +phrases. The structure is a little messy so I'll detail them here.

        +

        For words, the structure is like the following:

        +
        +    $word_search = {
        +        'word' => {
        +            substring => '1', # set to 1 if this is substring match
        +            phrase    => 0,   # not a phrase
        +            keyword   => 1,   # is a keyword
        +            mode      => '',  # can also be must, cannot to mean +/-
        +        },
        +        'word2' => ...
        +    }
        +

        For phrases the structure will become:

        +
        +    $phrase_search => {
        +        'phrase' => {
        +            substring => undef # never required
        +            phrase    => [
        +                'word1',
        +                'word2',
        +                'word3',
        +                ...
        +            ],              # for searching by indiv word if required
        +            keyword   => 0, # not a keyword
        +            mode      => ''    # can also be must, cannot
        +        },
        +        'phrase2' => ...
        +    }
        +

        Based on these structures, hopefully it will be easy enough to build whatever is +required to grab the appropriate records.

        +

        Finally, the second item passed in will be a hash filled with ID => score values +of search results. They look something like this:

        +
        +    $results = {
        +        1 => 56,
        +        2 => 31,
        +        4 => 6
        +    }
        +

        It is important for all the methods to take the results and return the results, +as the result set will be daisychained down like a set to be operated on by +various searching schemes.

        +

        At the end of the query, the results in this set will be sorted and returned to +the user as an sth.

        +

        Operations on this set are preformed by the following five methods.

        +
        +
        _query + +
        +

        This method is called just after all the query string has been parsed and put +into their proper buckets. This method is overridden by the INTERNAL driver to +decide it wants to switch to the NONINDEX driver for better performance.

        +
        +
        +

        Two parameters are passed in, ( $input, $buckets ). $input is a hash that +contains all the form/cgi parameters passed to the $tbl->query function and +$buckets is s the structure that is created after the query string is parsed. +You may also call $self->SUPER::_query( $input, $buckets ) to pass the request +along normally.

        +
        +
        +

        You must return undef or an STH from this function.

        +
        + +
        _union_query + +
        +

        This method takes a $word_search and does a simple match query. If it finds +records with any of the words included, it will append the results to the list. +Passed in is the $results and it must return the altered results set.

        +
        +
        +

        This method must also implement substring searching.

        +
        + +
        _phrase_query + +
        +

        Just like the union_query, however it searches based on phrases.

        +
        + +
        _phrase_intersect_query + +
        +

        This takes a $phrase_search and a $result as parameters. This method must look +to find results that are found within the current result set that have the +passed phrases as well. However, if there are no results found, this method can +look for more results.

        +
        + +
        _intersect_query + +
        +

        Takes two parameters, a $word_search, and $results. Just like the +_phrase_intersect query, if there are results already, tries to whittle away the +result set. If there are no results, tries to look for results that have all the +keywords in a record.

        +
        +
        +

        This method must also implement substring searching.

        +
        + +
        _disjoin_query + +
        +

        Takes two parameters, a $word_search, and $results. This will look through the +result set and remove all matches to any of the keywords.

        +
        +
        +

        This method must also implement substring searching.

        +
        + +
        _phrase_disjoin_query + +
        +

        Two parameters, $phrase_search and $results are passed to this method. This does +the exact same thing as _disjoin_query but it looks for phrases.

        +
        + +
        query + +
        +

        If you choose to override this method, you will have full control of the query.

        +
        +
        +

        This method accepts a $CGI or a $HASH object and performs the following

        +
        +
        +
        +  Options:
        +         - paging
        +            mh            : max hits
        +            nh            : number hit (or page of hits)
        +            sb            : column to sort by (default is by score)
        +
        +
        +
        +         - searching
        +            ww            : whole word
        +            ma            : 1 => OR match, 0 => AND match, undefined => QUERY
        +            substring     : search for substrings of words
        +            bool          : 'and' => and search, 'or' => or search, '' => regular query
        +            query         : the string of things to ask for
        +
        +
        +
        +         - filtering
        +            field_name    : value       # Find all rows with field_name = value
        +            field_name    : ">value"    # Find all rows with field_name > value.
        +            field_name    : "<value"    # Find all rows with field_name < value.
        +            field_name-gt : value       # Find all rows with field_name > value.
        +            field_name-lt : value       # Find all rows with field_name < value.
        +
        +
        +

        The function must return a STH object. However, you may find useful the +GT::SQL::Search::STH object, which will automatically handle mh, nh, and +alternative sorting requests. All you will have to do is

        +
        +
        +
        +    sub query { ... your code ... return $self->sth( $results ); }
        +
        +
        +

        Where results is a hashref containing primarykeyvalue => scorevalues.

        +
        + +
        alternate_driver_query + +
        +

        There is no reason to override this method, however, if you would like to use +another driver's search instead of the current, this method will let you do so.

        +
        +
        +

        Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name +of the driver you'd like to use and $input is the parameters passed to the +method. Returned is an $sth value (undef if an error has occurred). This method +was used in the INTERNAL driver to shunt to NONINDEXED if it found the search +would take too long.

        +
        + +
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Table.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Table.html new file mode 100644 index 0000000..692dd96 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Table.html @@ -0,0 +1,834 @@ + + + + +GT::SQL::Table - a perl interface to manipulate a single SQL table. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Table - a perl interface to manipulate a single SQL table.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $sth = $table->select(Column3 => { Column => $value, Column2 => $value2 });
        +    $table->delete({ Column => $value });
        +    $table->insert({ Column1 => $val, Column2 => $value2 });
        +    $table->update({ SetCol => $val }, { WhereCol => $val2 });
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::Table provides methods to add, modify, delete and search over a single +SQL table.

        +

        The following methods are provided.

        +

        +

        +

        query, query_sth

        +

        query provides a simple and powerful method to search a table. It takes as +input either a hash, hash ref or CGI object making it especially useful +searching from web forms.

        +
        +    my $results = $db->query($in);
        +

        The return of query is an arrayref of arrayrefs. query_sth returns an STH +that you can fetch rows from.

        +

        Typical usage to go through the results is:

        +
        +    my $results = $db->query({ Title => 'foobar' });
        +    if ($results) {
        +        for my $result (@$results) {
        +            ...
        +        }
        +    }
        +

        To specify what to search, you simply pass in column => search value. However, +you can also pass in a lot of options to enhance your search:

        +

        Find all rows with field_name = value:

        +
        +    field_name    => value
        +

        Find all rows with field_name > value:

        +
        +    field_name    => ">value"
        +

        Find all rows with field_name < value:

        +
        +    field_name    => "<value"
        +

        Find all rows with field_name > value:

        +
        +    field_name-gt => value
        +

        Find all rows with field_name < value:

        +
        +    field_name-lt => value
        +

        Find all rows where any field_name = value:

        +
        +    keyword       => value
        +

        Find all rows using indexed search (see weights):

        +
        +    query         => value
        +

        Set to 1, use '=' comparison, 0/unspecified use 'LIKE '%val%' comparision:

        +
        +    ww            => 1
        +

        Search using LIKE for column 'Title' (valid opts are '=', '>', '<' or 'LIKE'):

        +
        +    Title-opt     => 'LIKE'
        +

        Set to 1, OR match results, 0/unspecified AND match results:

        +
        +    ma            => 1
        +

        Return a max of n results, defaults to 25:

        +
        +    mh            => n
        +

        Return page n of results:

        +
        +    nh            => n
        +

        Sort by 'Title' column:

        +
        +    sb            => 'Title'
        +

        Sort in ascending (ASC) or descending (DESC) order:

        +
        +    so            => 'ASC'
        +

        +

        +

        select

        +

        Select provides a way to implement almost any sql SELECT statement.

        +

        An executed statement handle is returned that you can call the normal fetchrow, +fetchrow_array, fetchrow_hashref, etc on.

        +
        +    my $sth = $obj->select;
        +

        is equivalant to ``SELECT * FROM Table''

        +
        +    my $sth = $obj->select({ Col => Val });
        +

        is equivalant to ``SELECT * FROM Table WHERE Col = 'Val'''.

        +
        +    my $sth = $obj->select('Col2', 'Col3', { Col => "Val" });
        +

        is equivalant to ``SELECT Col2,Col3 FROM Table WHERE Col => 'Val'''.

        +

        So you can pass in a hash reference which represents the where clause, and an +array reference where represents what you want to select on.

        +

        If you need more complex where clauses, you should use a condition object +instead of a hash reference. See the GT::SQL::Condition manpage for more information.

        +

        Notes:

        +
        +
        quoting in where + +
        +

        All arguments in the where clause are automatically quoted. If you don't want +quotes, you should pass in a scalar reference as in:

        +
        +
        +
        +    my $sth = $obj->select({ Col => \"NOW()" });
        +
        +
        +

        which turns into ``SELECT * FROM Table WHERE Col = NOW()''.

        +
        + +
        quoting in select + +
        +

        Nothing in the select will be quoted, so to use functions, simply pass in what +you want:

        +
        +
        +
        +    my $sth = $obj->select('COUNT(*)');
        +
        +
        +

        which turns into ``SELECT COUNT(*) FROM Table''.

        +
        + +
        +

        To specify LIMIT, or GROUP BY, or ORDER BY or other SELECT clauses that come +after the WHERE, you should use select_options below.

        +

        +

        +

        select_options

        +

        This method provides a way for you to specify select options such as LIMIT and +SORT_BY.

        +
        +    $obj->select_options(@OPTIONS);
        +

        @OPTIONS should be a list of options you want appended to your next select.

        +

        For example,

        +
        +    $obj->select_options('ORDER BY Foo', 'LIMIT 50');
        +    $obj->select;
        +

        would turn into ``SELECT * FROM Table ORDER BY Foo LIMIT 50''. To perform a +LIMIT with an OFFSET, you should specify something like:

        +
        +    $obj->select_options('LIMIT 25 OFFSET 75');
        +

        You can alternatively use the equivelant MySQL-specific syntax:

        +
        +    $obj->select_options('LIMIT 75, 25');
        +

        Both will be handled correctly regardless of the database type.

        +

        +

        +

        count

        +

        This method will allow you to count records based on a where clause.

        +
        +    my $count = $obj->count($condition);
        +

        count() takes either a condition or a hash reference. If no argument is +provided, it is equivalant to ``SELECT COUNT(*) FROM Table'', or total number of +rows.

        +

        +

        +

        hits

        +

        This method returns the number of hits from that last select query without +the limit clause if there was one.

        +
        +    $hits = $obj->hits;
        +

        For example, to get rows 20-30 of a query result, use:

        +
        +    $obj->select_options("LIMIT 10 OFFSET 20"); $obj->select({ Column => 'Foo' });
        +

        this translates into (in MySQL):

        +
        +    SELECT * FROM Table WHERE Column = 'Foo' LIMIT 20, 10
        +

        To see the total number of results that the query would have retrieved without +any limit, you call:

        +
        +    $hits = $obj->hits;
        +

        If the number of hits can be calculated, it will be returned to you without any +additional query. Otherwise, the following query will be performed +automatically, and the hit count returned to you:

        +
        +    SELECT COUNT(*) FROM Table WHERE Column = 'Foo'
        +

        NOTE: The hits() method _only_ applies to select queries. Most databases do +not provide enough information to get counts of rows affected for other types +of queries.

        +

        +

        +

        get

        +

        This method allows for a simple interface to retrieving records from the +table(s).

        +
        +    my $rec_hash_ref  = $obj->get($val);
        +    my $rec_hash_ref  = $obj->get($val, 'HASH', ['col1', 'col2']);
        +    my $rec_array_ref = $obj->get($val, 'ARRAY');
        +

        The first argument is the primary key value of the record you want to retrieve.

        +

        The second argument is a format option. It can be either 'ARRAY' or 'HASH' and +determines whether you are returned a HASH reference or an ARRAY reference. The +default is 'HASH', and it is optional.

        +

        The last argument is a list of column names you want retrieved. get defaults +to returning the entire record, but if you only need specific columns, you can +ask for the ones you want.

        +

        For example:

        +
        +    my $employee = $emp_db->get('Alex');
        +

        would return a hash ref of the record whose primary key is equal to 'Alex'.

        +
        +    my $emp_addr = $emp_db->get('Alex', 'HASH', ['City', 'State', 'ZipCode']);
        +

        would return a hash ref of only the three fields City, State, ZipCode for the +record whose primary key equals Alex.

        +

        +

        +

        add

        +

        Method to add an entry into the database. This method can take it's arguments +one of three ways.

        +
        +    $obj->add($CGI_OBJECT);
        +
        +    -or-
        +
        +    $obj->add({
        +        col1 => $val1,
        +        col2 => $val2,
        +        ...
        +    });
        +
        +    -or-
        +
        +    $obj->add(
        +        col1 => $val1,
        +        col2 => $val2,
        +        ...
        +    );
        +

        This method can take a cgi object, a hash reference or a hash. The keys of the +hash should be the names of the column and the values should be the values to +insert into the fields. The CGI Object is not different. If the table has an +auto_increment field, the value of the last inserted record will be returned.

        +

        add returns undef on failure. If successful, and the table has an +auto-increment field, the auto increment value is returned. If there is no +auto increment value, then 1 is returned. Any errors will be in +$GT::SQL::error.

        +

        Passing in GT_SQL_SKIP_CHECK => 1 will have the table module skip any error +checking it should perform.

        +

        Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the indexing method to do this.

        +

        +

        +

        insert

        +

        insert is a lower level add. The main differences between add and +insert are that add performs a not null check, and add returns the id of the +just inserted value.

        +

        insert does not perform a not null check. Also, insert returns the statement +handle used to do the insert (so you can call $sth->insert_id to get the auto +increment).

        +

        +

        +

        insert_multiple

        +

        insert_multiple will try to optimize the insertion of multiple rows with +simple values. Under MySQL, this uses MySQL's extended insert syntax:

        +
        +    INSERT INTO Table (col1, col2, col3)
        +    VALUES ('val1', 'val2', 'val3'), ('val4', 'val5', 'val6'), ...
        +

        On other databases, it attempts to perform all insertions in a single +transaction, which will also usually yield performance benefits. Note, +however, that insert_multiple should not be used for anything more complex +than basic column values - for example, inserting NULL to set the current date, +or using raw SQL by passing scalar references for values.

        +

        It takes at least two arguments - the first argument is an array ref of column +names, and the rest are array references of values. For example, to produce +the above example SQL code, you would call:

        +
        +    $table->insert_multiple(
        +        ['col1', 'col2', 'col3'],
        +        ['val1', 'val2', 'val3'],
        +        ['val4', 'val5', 'val6'],
        +        ...
        +    );
        +

        +

        +

        modify

        +

        This method is designed for modifying a single entry in the table. It takes as +input a hash, hash ref or CGI object, which is assumed to represent a single +row with all fields intact.

        +

        modify will then look for the primary key in the input and set all fields +for that row equal to what was passed in.

        +

        You need to pass in a complete record! If you just want to update one column, +you probably want to use update instead, as doing:

        +
        +    my $result = $obj->modify(column1 => 'Foo');
        +

        will blank out all the other fields and set just column1 to Foo.

        +

        modify returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error.

        +

        +

        +

        update

        +

        This method provides a more robust way to update multiple entries in the table.

        +
        +    my $result = $obj->update(
        +        {
        +            col1 => $val1,
        +            col2 => $val2,
        +            ...
        +        },
        +        $condition
        +    );
        +
        +    -or-
        +
        +    my $result = $obj->update(
        +        {
        +            col1 => $val1,
        +            col2 => $val2,
        +            ...
        +        },
        +        {
        +            col1 => $val1,
        +            col2 => $val2,
        +            ...
        +        }
        +    );
        +

        In both these cases the first argument is a hash reference with the column +names as the keys and the new values you want the columns to hold as the +values. The second argument can either be a condition object or a hash +reference. If it is a hash reference the keys will be used as the column names +and the values will be taken as the current column values for the where clause +to update the table.

        +
        +    $obj->update({ Setme => 'NewValue'}, { WhereCol => 5 });
        +

        would set the column 'Setme' to 'NewValue' where the column 'WhereCol' is 5. +This translates to:

        +
        +    UPDATE Table SET SetMe='NewValue' WHERE WhereCol = 5
        +

        If the second argument is a GT::SQL::Condition object the condition object will +be used to build the where clause with. Please see the GT::SQL::Condition manpage for a +description of what you can do with a where clause.

        +
        +    my $condition = GT::SQL::Condition->new('WhereCol', 'LIKE', 'Foo%');
        +    $obj->update({ Setme => 'Newvalue' }, $condition);
        +

        would translate to:

        +
        +    UPDATE Table SET Setme = 'Newvalue' WHERE WhereCol LIKE 'Foo%'
        +

        The condition can now much more complex where clauses though.

        +

        update returns undef on failure and the a the GT::SQL::Driver manpage statement +handle on success. The error message will be available in $GT::SQL::error.

        +

        Passing in GT_SQL_SKIP_CHECK => 1 as a third option to update will have the +table module skip any error checking it should perform.

        +

        Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use +the indexing method to do this.

        +

        +

        +

        delete

        +

        This method provides a robust interface to delete entries from your table(s) +using join and or foreign key relations.

        +
        +    my $result = $obj->delete($condition);
        +

        You can pass into delete either a condition object to delete multiple +entries, or a scalar value to delete the row whose primary key equals the +value. If you have a multiple primary key, then you can pass in an array ref to +delete that row.

        +
        +    my $result = $obj->delete({
        +        col1 => $val1,
        +        col2 => $val2,
        +        ...
        +    );
        +
        +    -or-
        +
        +    $obj->delete($val);
        +
        +    -or-
        +
        +    $obj->delete([$val1, $val2]);
        +

        delete returns undef on failure, 1 on success. The error message will be +available in $GT::SQL::error.

        +

        +

        +

        delete_all

        +

        This method takes no arguments and will erase all entries from a table.

        +

        +

        +

        Table Properties

        +

        Table provides a lot of methods to access information about the table:

        +
        +
        name + +
        +

        Provides the name of the table minus any prefix.

        +
        + +
        ai + +
        +

        Returns the name of the auto-increment field if any.

        +
        + +
        pk + +
        +

        Returns an array(ref) of primary key column names.

        +
        + +
        fk + +
        +

        Returns a hash of foreign key values.

        +
        + +
        fk_tables + +
        +

        Returns a list of tables with foreign keys pointing to this table.

        +
        + +
        index + +
        +

        Returns a hash ref of index name => array ref of column names that index uses.

        +
        + +
        unique + +
        +

        Returns a hash ref of unique index names => array ref of column names that +unique index uses.

        +
        + +
        all_indexes + +
        +

        Returns the joined output of index and unique and primary key.

        +
        + +
        cols + +
        +

        Returns a hash(ref) of column name => column definition

        +
        + +
        default + +
        +

        Returns a hash(ref) of column name => default value.

        +
        + +
        size + +
        +

        Returns a hash(ref) of column name => size of column in SQL.

        +
        + +
        type + +
        +

        Returns a hash(ref) of column name => type of column in SQL.

        +
        + +
        form_display + +
        +

        Returns a hash(ref) of column name => name to display on auto generated forms +(think pretty name).

        +
        + +
        form_size + +
        +

        Returns a hash(ref) of column name => size of html form to generate.

        +
        + +
        form_type + +
        +

        Returns a hash(ref) of column name => type of html form to generate (checkbox, +select, text, etc).

        +
        + +
        form_names + +
        +

        Returns a hash(ref) of column name => array ref of form names. This is used for +multi option form elements like checkboxes and multi selects. The name is what +is displayed to the user and not entered in the database.

        +
        + +
        form_values + +
        +

        Returns a hash(ref) of column name => array ref of form values. Same as above, +but this is the value that actually gets entered.

        +
        + +
        time_check + +
        +

        Returns a hash(ref) of column name => time check on or off. If set

        +
        + +
        regex + +
        +

        Returns a hash(ref) of column name => regular expression that all input must +pass before being inserted.

        +
        + +
        pos + +
        +

        Returns a hash(ref) of column name => position in table.

        +
        + +
        not_null + +
        +

        Returns a hash(ref) of column name => not null (whether the field is allowed to +be null or not).

        +
        + +
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Table.pm,v 1.274 2008/09/17 19:35:24 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree.html new file mode 100644 index 0000000..bef95a1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree.html @@ -0,0 +1,693 @@ + + + + +GT::SQL::Tree - Helps create and manage a tree in an SQL database. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Tree - Helps create and manage a tree in an SQL database.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::SQL::Tree;
        +
        +    my $tree = $table->tree;
        +    my $children = $tree->children(id => [1,2,3], max_depth => 2);
        +
        +    my $parents = $tree->parents(id => [4,5,6]);
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::Tree is designed to implement a tree structure with a SQL table. Most +of the work on managing the table is performed automatically behind the scenes, +however there are a couple of front end methods to retrieving the tree nodes +from a GT::SQL::Tree object.

        +

        +

        +
        +

        METHODS

        +

        +

        +

        new, tree

        +

        Typically, the way to get a tree object is to call ->tree on a table object. The +table object then calls GT::SQL::Tree->new for you and returns the results, +which is a GT::SQL::Tree object. Typically you should not call ->new directly, +but instead let $table->tree call it with the proper arguments.

        +

        +

        +

        create, add_tree

        +

        To use GT::SQL::Tree, you need to first call create(). You shouldn't call it +directly, but instead call ->add_tree() on an editor object. The arguments to +add_tree are passed through to create, so that they are essentially the same +(there is one exception - add_tree passed in table => $table_object).

        +

        create() will create a tree table, with the name passed on the name of the table +passed in. For example, if you wish to build a tree on 'MyTable', the tree table +that is created by create() will be named MyTable_tree. The tree table provides +easy one-query access to all of a nodes parents or children, and also keeps +track of the number of hops between a node and its descendant, allowing you to +limit how far you descend into the tree.

        +

        The following arguments are required:

        +
        +
        table + +
        +

        This contains the table object for the table the tree is to be built upon. Note +that when calling add_tree you should not specify this - add_tree passes it +along on its own.

        +
        + +
        father + +
        +

        This must specify the name of the father ID column. The father ID column +controls the relationship between father/child.

        +
        +
        +

        For example, if your primary key is ``my_id'' and your father id column is +``my_father_id'', you would pass in ``my_father_id'' as the value to father.

        +
        + +
        root + +
        +

        This is used to specify the name of the root column. For example, if your +primary key is ``my_id'' and your root id column is ``my_root_id'', you would pass +in ``my_root_id'' as the value to root.

        +
        + +
        depth + +
        +

        This is used to specify the name of the depth column for the table. For example, +if you are using a column named ``my_depth'' to keep track of the depth of a node, +you would pass in ``my_depth'' as the value to depth.

        +
        + +
        +

        The following are optional arguments to create/add_tree:

        +
        +
        force + +
        +

        Takes a value such as 'force' or 'check'. This value is passed on to the +GT::SQL table creation subroutine.

        +
        + +
        rebuild + +
        +

        You can pass in a GT::SQL::Tree::Rebuild object if you have an incomplete or +invalid table structure. See the GT::SQL::Tree::Rebuild manpage for more details.

        +
        + +
        debug + +
        +

        Sets the debug level of the tree object. add_tree() automatically passes in the +debug value for the table object, so it normally is not necessary to set this.

        +
        + +
        +

        +

        +

        destroy, drop_tree

        +

        You can call $tree->destroy to destroy a tree. This involves dropping the +tree table and deleting the tree reference from the table the tree was on. This +can be called by calling $tree->destroy() on a GT::SQL::Tree object, +however this is typically invoked by calling $editor->drop_tree() on a +table editor object.

        +

        Neither $tree->destroy() nor $editor->drop_tree() take any +arguments.

        +

        +

        +

        root_id_col, father_id_co, depth_col

        +

        These three tree object methods return the name of the associated column in the +main table. Usually you will already know them, and these methods are primarily +used internally.

        +

        +

        +

        children

        +

        This is where the usefulness of the tree module comes into play. +$tree->children is used to access all of the children of a particular +node. It takes a wide variety of arguments to control the return.

        +

        Usually, the return will be either a hash reference of array references each +containing hash references, or else an array reference of hash references. Which +reference you get depends on what you request via the id parameter, described +below. Each inner hash reference is a row from the database, typically a joined +row from the table the tree is on with the tree table, however the +roots_only, cols, and select_from parameters all change this behaviour.

        +

        The arguments to children() are as follows:

        +
        +
        id + +
        +

        The value of the id key is either a scalar value, or an array reference. The +value/values to id should be the id whose descendants you are looking for. For +example, if you are looking for the children of ID 3 and ID 4, you would pass in +id => [3, 4]. The return value of children will be a hash reference +containing two keys: 3 and 4.

        +
        +
        +

        If you are looking for the children of a single ID and pass the id as a scalar +value, you will get back an array reference as described above.

        +
        +
        +

        So, basically, if the value to id is an array reference, you will get back a +hash reference of array references of hash references; if it is a scalar value, +you will get back an array reference of hash references. + $tree->children(id => [1])->{1}; +and + $tree->children(id => 1); +will result in the same thing.

        +
        +
        +

        To get all the trees in a single query, you pass in 0 as the value. This is as +if you are requesting the children of the imaginary root to which all roots +belong.

        +
        +
        +

        id is the only required parameter.

        +
        + +
        max_depth + +
        +

        You can specify a max_depth value to specify that the records returned should +not be more a certain distance from the node. For example, supposing you have +this tree: + a + b + c + d +Selecting the children of a with a max_depth of 1 would return just b, not c or +d. A max_depth of 2 would return b and c.

        +
        +
        +

        Not specifying max_depth means that you do not want to limit the maximum +distance from the parent of the returned values.

        +
        + +
        cols + +
        +

        You can specify an array reference as the value to cols to alter the values +returned. Instead of doing ``SELECT * FROM ...'', the query will be ``SELECT <what +you specify> FROM ...''. Note, however, that the father, root, and depth columns +are required and will be present in the rows returned whether or not you specify +them.

        +
        + +
        sort_col, sort_order + +
        +

        Where the sort option sorts the results based on tree levels, sort_col and +sort_order control the sorting for nodes with the same father ID. For +example, with this tree: + a + b + c +sort_col and sort_order affect whether or not b comes before or after c. +The value of each can either be a scalar value or an array reference. There is +essentially no difference, the scalar value is just a little easier when you are +only sorting on a single column. The values of sort_col should be column +names, and the values of sort_order 'ASC' or 'DESC', per sort column +respectively. For example: + sort_col => ['a','b'], sort_order => ['ASC', 'DESC'] +will sort first in ascending order based on the value of a, then descending +order based on the value of column b. This correlates directly to SQL - it +becomes ``ORDER BY a ASC, b DESC''.

        +
        +
        +

        You can specify a different sort order for roots by using the roots_order_by +option, when using id => 0. See below.

        +
        + +
        condition + +
        +

        If you want to limit the results, you can pass a GT::SQL::Condition object into +children() via the condition key. The condition will apply to the select +performed. For example, if you want to select rows with a column ``a'' having a +value less than 20, you could do: + my $cond = GT::SQL::Condition->new(a => '<' => 20) + my $children = $tree->children(..., condition => $cond);

        +
        + +
        limit + +
        +

        Like condition, you can specify any valid LIMIT _____ value here, for example +``50, 25''. This option is only used when using id => 0 - it will limit the +number of roots returned, taking into account the sort_col and sort_order.

        +
        + +
        roots_only + +
        +

        If you specify this option, it will assume that what you passed in via id +consists only of root_ids. Doing so makes a join with the tree table +unneccessary and allows you to use the select_from option. This option can be +used (and generally this is a good idea) when specifying id => 0.

        +
        + +
        roots_order_by + +
        +

        This option controlls the order of root posts, when selecting roots using +id => 0 and a limit. sort_order above will affect the order of +children of the roots, but the order of the roots themselves will be controlled +by whatever ORDER BY value you specify here.

        +
        +
        +

        Again, this option requires that id => 0, roots_only, and limit are +also being used.

        +
        +
        +

        If this option is omitted, the ORDER BY will be generated from the values of +the sort_col and sort_order options.

        +
        + +
        select_from + +
        +

        If you are using roots_only, you can also specify the select_from option. +This option allows you to perform the selects from a GT::SQL::Relation object +instead of just the table associated with the tree. Note that the table +associated with the tree must be part of the relation, however you can have as +many other tables as you like.

        +
        + +
        left_join + +
        +

        If the select_from relation should be a left join, pass left_join => 1. +This simply passes the left_join option to ->select. This option is only +applicable when select_from is used.

        +
        + +
        +

        +

        +

        parents

        +

        This is effectively the opposite of children. Instead of getting back all of the +children nodes, it gives the parents, all the way up to the root for any given +node. The return value is the same as that of children, so see that section.

        +

        Each array returned by children is sorted by depth from root to parent.

        +
        +
        id + +
        +

        id is the only required parameter for parents(). It should be either a +scalar value or an array reference. You specify the ID's of children whose +parents you are looking for. The type of argument (scalar or array ref) affects +the return in the same way as children().

        +
        + +
        cols + +
        +

        cols works in a similar way to the cols parameter to children. You +specify the columns you want in the return as an array ref. What you get back +will have these columns in it. If cols is not specified, you'll get back all +columns.

        +
        +
        +

        Note that 'tree_id_fk' and the depth column for the table are required fields +and will be added if not specified.

        +
        + +
        +

        +

        +

        child_ids

        +

        If you are looking for just the ID's of the children of a particular node, you +should use this. The return value is one of the following, depending on what you +pass in:

        +

        hash reference of array references: + { ID => [ID, ID, ...], ... } +with one ID in the hash reference for each id you specify. The array reference +contains the child ID's of the key ID.

        +

        hash reference of hash references: + { ID => { ID => dist, ID => dist, ... }, ... } +with one ID in the other hash reference for each id you specify. The inner hash +reference is made of child_id => child_distance key-value pairs.

        +

        array reference or hash reference: + [ID, ID, ...] +hash reference: + { ID => dist, ID => dist }

        +

        The first two apply when passing in an array reference for id, the latter two +when passing a scalar value for id. The first and third are without +include_dist specified, the second and fourth occur when you specify +include_dist.

        +
        +
        id + +
        +

        Like all other accessors, child_ids takes a scalar value or array reference as +the id value. Return as noted above.

        +
        + +
        include_dist + +
        +

        This changes the return as noted above - instead of just getting an array +reference of child ID's, you get the child ID's as the keys of a hash reference, +and the distances of the child from the parent you requested as the values.

        +
        + +
        +

        +

        +

        parent_ids

        +

        Exactly the same as child_ids, except that this works up the tree instead of +down. Takes the same arguments, gives the same possible returns.

        +

        +

        +
        +

        INDICES

        +

        A tree requires a few indices to get optimal performance out of it. If the table +is never expected to be more than just a few rows, you won't notice a +substantial difference, however, as with any table, as the table grows the +performance proper indexing provides becomes more appreciable.

        +

        Two indices are created automatically on the tree table, one on tree_id_fk, and +the other on tree_anc_id_fk,tree_dist, so you don't need to worry about that +table.

        +

        Obviously, the usage of the tree affects how many indices you want, this section +is simply to provide some general guidelines for the indices required.

        +

        Because the roots_only option is based solely on the main table and not the +tree, if you are using roots_only (calling children with id => 0 automatically +turns on the roots_only option), you want to make sure you have an index on the +root column. If you also use the max_depth depth option, add the depth column to +this index.

        +

        Keep in mind that you may need to mix other columns in here if you are using a +condition with children(). This also applies when using the sort_col and +sort_order parameters - basically you need to figure out what your indices +are, and then add in the root column and, if using max_depth, the depth column.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Tree.pm,v 1.30 2008/06/11 06:55:26 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree/Rebuild.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree/Rebuild.html new file mode 100644 index 0000000..ac7ffc7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Tree/Rebuild.html @@ -0,0 +1,426 @@ + + + + +GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::SQL::Tree;
        +    use GT::SQL::Tree::Rebuild;
        +
        +    my $rebuild = GT::SQL::Tree::Rebuild->new(
        +        table => $DB->table('MyTable'),
        +        missing_root => \&root_code,
        +        missing_father => \&father_code,
        +        missing_depth => \&depth_code,
        +        order_by => 'column_name'
        +    );
        +
        +    $DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild);
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and +aids in turning an existing table into one with the neccessary root, father and +depth columns needed by GT::SQL::Tree.

        +

        The main purpose is to do a one-shot conversion of a table to make it compatible +with GT::SQL::Tree.

        +

        +

        +

        new - Create a Rebuild object

        +

        There is only one method that is called - new. You pass the arguments needed +and get back a GT::SQL::Tree::Rebuild object. This object should then be passed +into GT::SQL::Tree->create (typically via $editor->add_tree())

        +

        new() takes a hash with up to 4 argument pairs: ``table'' (required), and one or +more of ``missing_root'', ``missing_father'', or ``missing_depth''. The values are +explained below.

        +
        +
        table + +
        +

        Required. You specify the table object for the table to rebuild. For example, if +you are going to add a tree to the ``Category'' table, you provide the ``Category'' +table object here.

        +
        + +
        cols + +
        +

        By default, an entire row will be returned. To speed up the process and lower +the memory usage, you can use the cols option, which specifies the columns to +select for $row. It is recommended that you only select columns that you need as +doing so will definately save time and memory.

        +
        + +
        missing_father, missing_root, missing_depth + +
        +

        Each of these arguments takes a code reference as its value. The arguments to +the code references are as follows:

        +
        +
        +
        $row + +
        +

        The first argument is a hash reference of the row being examined. Your job, in +the code reference, is to examine $row and determine the missing value, +depending on which code reference is being called. missing_root needs to return +the root_id for this row; missing_father needs to return the father_id, and the +missing_depth code reference should return the depth for the row.

        +
        + +
        $table + +
        +

        The second argument passed to the code references is the same table object that +you pass into new(), which you can select from if neccessary.

        +
        + +
        +
        missing_father + +
        +

        The missing_father code reference is called first - before missing_root +and missing_depth. The code reference is called as described above and should +return the ID of the father of the row passed in. A false return (0 or undef) is +interpreted as meaning that this is a root and therefore has no father.

        +
        + +
        missing_root + +
        +

        missing_root has to return the root of the row passed in. This is called +after missing_father, so the $row will contain whatever you returned in +missing_father in the father ID column. Of course, this only applies if using +both missing_root and missing_father.

        +
        + +
        missing_depth + +
        +

        missing_depth has to return the depth of the row passed in. This is called +last, so if you are also using missing_father and/or missing_root, you +will have whatever was returned by those code refs available in the $row.

        +
        + +
        order_by + +
        +

        The query done to retrieve records can be sorted using the order_by option. +It should be anything valid for ``ORDER BY _____''. Often it can be useful to have +your results returned in a certain order - for example: + order_by => 'depth_column ASC' +would insure that parents come before roots. Of course, this example wouldn't +work if you are using ``missing_depth'' since none of the depth values will be +set.

        +
        + +
        +

        Once you have a GT::SQL::Tree::Rebuild object, you should pass it into +GT::SQL::Tree->create (which typically involves passing it into +$editor->add_tree(), which passed it through). Before calculating the +tree, GT::SQL::Tree will call on the rebuild object to reproduce the father, +root, and/or depth columns (whichever you specified).

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Types.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Types.html new file mode 100644 index 0000000..1f8a456 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/SQL/Types.html @@ -0,0 +1,726 @@ + + + + +GT::SQL::Driver::Types - Column types supported by GT::SQL + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::SQL::Driver::Types - Column types supported by GT::SQL

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $c = $DB->creator('new_table');
        +    $c->cols({
        +        column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 }
        +        # ... more columns ...
        +    });
        +
        +    my $e = $DB->editor('table_name');
        +    $e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' });
        +

        +

        +
        +

        DESCRIPTION

        +

        This module should not be used directly, however the documentation here +describes the different types support by GT::SQL and any caveats associated +with those types.

        +

        +

        +
        +

        ATTRIBUTES

        +

        All types are specified as a column_name => { column definition } pair, +where the column definition should contain at least a type key containing +one of the TYPES outlined below. Commonly accepted attributes are:

        +
        +
        not_null + +
        +

        Used to specify that a column should not be allowed to contain NULL values. +Note that for character/string data types, a 0-character string (and, for +CHAR/VARCHAR columns, strings containing only spaces), are considered +NULL values are are not permitted if the column is specified as not_null. +The value passed to not_null should be true.

        +
        + +
        default + +
        +

        Used to specify a default value to be used for the column when no explicit +value is provided when a row is inserted. The default value is also used for +the value in existing rows when adding a not_null column to an existing table - +in such a case, the default is required.

        +
        +
        +

        Also see the TEXT section regarding caveats and limitations of +using default's for TEXT types.

        +
        + +
        +

        Other column attributes are supported as outlined below. In addition to +attributes mentioned in this document, various attributes are available that +influence automatically-generated forms displayed by GT::SQL::Admin - see +the GT::SQL::Creator manpage for details on these attributes.

        +

        +

        +
        +

        TYPES

        +

        +

        +

        Integer types

        +
        +
        TINYINT + +
        +

        The TINYINT type specifies an 8-bit integer able to handle values from -128 +to 127. Some databases will allow larger values due to not supporting an +appropriate data type. The unsigned column attribute may turn this into +an unsigned value supporting values from 0 to 255; due to this type being +implemented as a larger integer type in some databases (which, incidentally, +coincide with the databases not supporting an unsigned 8-bit TINYINT) using +an unsigned TINYINT type will result in a column able to store any value +from 0-255, unlike most of the larger integer types below.

        +
        + +
        SMALLINT + +
        +

        The SMALLINT type specifies a 16-bit integer able to handle values from +-32768 to 32767. The unsigned column attribute may turn this into an +unsigned value supporting values from 0 to 65535, however this is not +guaranteed. If you need to store values in the 32768-65535 range, a larger +type is recommended.

        +
        + +
        MEDIUMINT + +
        +

        The MEDIUMINT type (only natively supported by MySQL) specifies a 24-bit +integer type able to hold values from -8388608 to 8388607. If the unsigned +column attribute is specified, this allows values from 0 to 16777215. Due to +this being supported with the unsigned attribute, or implemented as a larger +data type, an unsigned MEDIUMINT will always supported values up to +16777215.

        +
        + +
        INT, INTEGER + +
        +

        The INT type specifies a 32-bit integer able to hold values from -2147483648 +to 2147483647. If the unsigned column attribute is specified, the column +may support values from 0 to 4294967295, however this is not guaranteed. +If values larger than 2147483647 are needed, using the BIGINT type below is +recommended. INTEGER is an alias for INT.

        +
        + +
        BIGINT + +
        +

        The largest integral type, BIGINT specifies a 64-bit integer value able to +hold values from -9223372036854775808 to 9223372036854775807. If specified as +unsigned, the column may support values from 0 to 18446744073709551616, +but this is not guaranteed. If larger values are needed, use the DECIMAL +type with a scale value of 0.

        +
        + +
        +

        +

        +

        Float-point types

        +
        +
        REAL, FLOAT + +
        +

        The REAL type specifies a 32-bit floating-point (i.e. fractional) number, +accurate to 23 binary digits (which works out to approximately 6 decimal +digits). The values may be signed, and can range from at least as small as +10^-37 to at least as large as 10^37. For more precise values, the DOUBLE +type is recommended. For exact precision (i.e. for monetary values), the +(often slower) DECIMAL type is recommended. FLOAT is an alias for +REAL.

        +
        + +
        DOUBLE + +
        +

        The DOUBLE type specifies a 64-bit floating-point (i.e. fractional) number, +accurate to 52 binary digits (approximately 15 decimal digits). The values +may be signed, and can range from at least as small as 10^-307 to at least as +large as 10^308 (except under Oracle - see below). For exact precision (i.e. +for monetary values), the (often slower) DECIMAL type is recommended.

        +
        +
        +

        Take note that Oracle doesn't properly support the full range supported by +other databases' DOUBLE types - the smallest number supported (assuming +precision to digits) is 10^-113 - specifically, the number of digits after the +decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while +1.23456789012e-117 is not. The larger number Oracle supports is just less than +1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you +need to store numbers larger or smaller than this amount, you'll have to find +some other way to store your numbers (i.e. Math::BigFloat with a VARCHAR).

        +
        + +
        +

        +

        +

        Aribtrary precision numbers

        +
        +
        DECIMAL + +
        +

        The DECIMAL type is provided to support numbers of arbitrary precision. It +requires two attributes, scale and precision, where scale specifies +the number of decimal places, and precision specifies the number of overall +digits. For example, 123.45 has a precision of 5, and a scale of 2. +42 has a precision or 2, and a scale of 0. scale must be less than +precision, and precision must not exceed 38. Also, although the value +stored and retrieved is completely accurate within it's given precision and +scale range, the accuracy available for comparisons (i.e. column = number) is +only reliably accurate to approximately the same level as DOUBLE's - that is, +about 15 digits.

        +
        + +
        +

        +

        +

        Character types

        +
        +
        CHAR + +
        +

        The CHAR type is used to specify a string of characters from 1 to 255 +characters long. It takes a size attribute which must be 255 or less, and +specifies the size of the column values - if not specified, 255 will be used. +This implementation's CHAR type, for historic reasons, will not pad +inserted values with spaces, but may trim trailing spaces when retrieving +and/or comparing values. Note that this is not SQL compliant CHAR +behaviour - SQL-compliant CHAR's are padded with spaces up to their size.

        +
        +
        +

        What this ends up meaning is that for everything except MySQL, CHAR columns +will be mapped to VARCHAR columns. Note that even MySQL, which is the only +database for which CHAR's are not automatically mapped into VARCHAR's, +will transparently convert CHAR columns to VARCHAR columns if any +non-fixed-size datatype (anything other than a CHAR or numeric types) is +used in or added to the table. As a general rule, VARCHAR is preferred over +CHAR except when dealing with columns whose values don't vary significantly +in length and are in a table that only contains fixed-size data types +(CHAR's and numeric types). Everywhere else, use VARCHAR's, since that's +what you'll be getting anyway.

        +
        +
        +

        A binary attribute is supported, which may indicates that comparisons +with this field should be case-sensitive. Note that this only works on +databases that actually have a case-sensitive CHAR field - currently, only +MySQL.

        +
        + +
        VARCHAR + +
        +

        The VARCHAR type is identical to the above CHAR type except as +follows. Unlike a CHAR, a VARCHAR column does not take up size bytes +of storage space - typically the storage space is only slightly larger +(typically 1 byte) than the size of the value stored. As such, VARCHAR's +are almost always preferred over columns, except for nearly-constant sized +data, or tables with all fixed-width data types (CHAR's, INT's, and +non-DECIMAL numeric types). VARCHAR columns will not be padded with +whitespace up to size, however trailing whitespace may be trimmed from +values.

        +
        +
        +

        As with CHAR, the binary attribute may make the VARCHAR values +case-sensitive for the matching purposes.

        +
        + +
        TEXT + +
        +

        The TEXT type is similar to VARCHAR types, except that they are always +case-insensitive for matching/equality, and can contain longer values. The +TEXT type takes a size attribute which contains the length required - if +not provided, a value of approximately 2 billion is used. Note that the +maximum size of the column will usually be larger than the value you specify to +size - it simply indicates to the driver to use a field capable of at least +the size specified. The values of TEXT fields are case-insensitive in terms +of matches and equality. The maximum size value, and the default, is +approximately 2 billion.

        +
        +
        +

        Certain aliases are provided with implicit size defaults - TINYTEXT, +SMALLTEXT, MEDIUMTEXT, and LONGTEXT, which are equivelant to TEXT +with size values of 255, 65535, 16777215, and 2147483647, respectively.

        +
        +
        +

        Depending on the size value, certain databases _may_ use different +underlying types. MySQL, for example, uses the smallest possible type between +its native TINYTEXT, TEXT, MEDIUMTEXT, and LONGTEXT types. As +such, it is recommended that you use a sufficiently large size value unless +absolutely sure that you will never need a larger value.

        +
        +
        +

        Also note that TEXT types do not support normal equality operations - in +fact, the only portable things that can be done with TEXT columns is IS +NULL tests (in GT::SQL this means ``='' undef) and LIKE comparisons - but, +for portability with all supported databases, the argument of a LIKE may not +exceed 4000 characters.

        +
        +
        +

        Also note that the default value will be ignored by MySQL, which does not +support having default values on TEXT columns. Everything else, however, +will properly support this, and the default will still be used when inserting +with GT::SQL even when using MySQL. Also note that the default value of +TEXT types must not exceed 3998 characters, due to limits imposed by some +databases. Longer indexes may work in some cases, but are not guaranteed - for +example, a table resync on MSSQL will not work.

        +
        + +
        ENUM + +
        +

        The ENUM type is a MySQL-only type that supports certain fixed string +values. On non-MySQL databases, it is simply mapped to a VARCHAR column. +It requires a values option which should have a value of an array reference +of string values that the ENUM should permit. The ENUM type is generally +discouraged in favour of a CHAR, VARCHAR, or an +integral type column, all of which provide more flexibility +(i.e. if you want to add a new possible value) and are not a single +database-specific type.

        +
        + +
        +

        +

        +

        Date/time types

        +

        All of the date/time types support by MySQL will be handled by GT::SQL, for +compatibility reasons. However, all types other than DATE and DATETIME +should be considered deprecated as cross-database compatibility is not possible +using these types. In particular, TIMESTAMP will work exactly like a +DATETIME on every non-MySQL database; TIME and DATE will work in +Postgres just like they do in MySQL; under everything else, TIME won't work +at all, and DATE will work like DATETIME.

        +

        GT::SQL users are urged to at least consider using an INT column, designed to +contain Perl's time() value, in lieu of any of the Date/time types as it avoids +many problems typically associated with storing local times - such as time zone +issues and non-local databases. That said, if you are certain you want a +Date/time type, a DATETIME is preferred as it will work (almost) the same +everywhere.

        +
        +
        DATETIME + +
        +

        A date field, which stores values in YYYY-MM-DD HH:MM:SS format (where +'HH' is a 24-hour hour). Inserted values may omit the seconds +(YYYY-MM-DD HH:MM), or time (YYYY-MM-DD) portions of the value. Omitted +values will default to 0.

        +
        +
        +

        Note that DATETIME values returned from a database may include +fractional-second precision values such as 2004-01-01 12:00:07.123. +Currently MSSQL and Postgres exhibit this behaviour. MSSQL's DATETIME type +always includes exactly three decimal digits, while Postgres' TIMESTAMP type, +used for GT::SQL DATETIME's, stores times with 6 decimal-digit precision. +Unlike MSSQL, however, Postgres will only display decimal digits if a +significant decimal value has been stored in the database. This happens with +the time_check option, below, and when an explicit fractional second value +has been inserted into the database.

        +
        +
        +

        A time_check attribute may be passed with a true value; if set, any update +to the row that doesn't explicitly set the column will have the column updated +to the database's current local time. Due to issues with times and/or +timezones, this option should be considered deprecated and discouraged - it is +recommended instead that you update the value yourself using a value that +your script thinks is local time (or, better yet, use an INT column with +unix time values (i.e. time() in Perl), which are timezone-independent to begin +with), rather than trying to depend on a database having the same time and time +zone as your script.

        +
        + +
        DATE + +
        +

        Just like DATETIME, except (under MySQL and Postgres) it only stores and +returns the YYYY-MM-DD portion of the value. Note that when using this +type, care must be taken to extract only the desired portion of the output as +databases other than MySQL and Postgres map this to a DATETIME above, which +returns 'YYYY-MM-DD HH:MM:SS' values (with a possible fractional seconds value, +in the case of MSSQL/Postgres). Using a DATETIME or INT field is +generally preferred, but this type may be slightly more effecient and take +slightly less space (4 bytes instead of 8 bytes) on MySQL and Postgres +databases.

        +
        +
        +

        Like DATETIME, this handles a time_check field, with the same caveats +described in the the DATETIME time_check description.

        +
        + +
        +

        The alternate, deprecated date/time types supported are listed in the +Deprecated types section below.

        +

        +

        +

        Deprecated types

        +
        +
        BLOB + +
        +

        Limited BLOB support (TINYBLOB, BLOB, MEDIUMBLOB, and LONGBLOB) +existed in older versions of GT::SQL, however the support, where it existed at +all, was partial and incomplete. Additionally, only certain drivers (MySQL and +Oracle) supported BLOB types at all. As such, the limited BLOB support +present in old GT::SQL versions is still supported under MySQL and Oracle, but +any new development should avoid them. If you really need to store binary +data, it is strongly recommended that you use files, and simply store +filenames in the database.

        +
        + +
        TIMESTAMP + +
        +

        This extremely odd MySQL data type, depending on the version of MySQL, stores +times in either the format described in DATETIME (MySQL 4.1+) or an +extremely MySQL-specific YYYYMMDDhhmmss format. Another MySQL-specific of +this data type is that the first - and ONLY the first - TIMESTAMP column in +a row will be automatically updated to the current local timezone-dependent +date and time. Use a DATETIME (possibly with the time_check option) +instead.

        +
        + +
        TIME + +
        +

        A MySQL and Postgres-specific type that stores only the time-of-day in +HH:MM:SS format. Deprecated due to non-portability and incompatibility on +other databases. If you really want to store just the time of day, either use +an INT to store the minutes or seconds since midnight, or use a CHAR +which you update with the HH:MM:SS value. Causes a fatal error on databases +which don't have an appropriate native type.

        +
        + +
        YEAR + +
        +

        A particularly useless MySQL-specific data type that stores only the year +portion of a date. Use a SMALLINT instead. Causes a fatal error on +anything other than MySQL.

        +
        + +
        +

        +

        +
        +

        SEE ALSO

        +

        the GT::SQL manpage

        +

        the GT::SQL::Creator manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Types.pm,v 1.3 2006/05/26 21:56:31 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/File.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/File.html new file mode 100644 index 0000000..c5ce525 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/File.html @@ -0,0 +1,308 @@ + + + + +GT::Session::File - A session management module, with simple data storage/retrieval. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Session::File - A session management module, with simple data storage/retrieval.

        +

        +

        +
        +

        SYNOPSIS

        +

        Create a session: + my $session = new GT::Session::File; + my $id = $session->id();

        +

        Save data with the session: + $session->data (``Save this information!'');

        +

        Load a session. + my $session = new GT::Session::File ( $id ) or die ``Can't load session: '$id'.''

        +

        Set session directory. + my $session = new GT::Session::File ( directory => '/path/to/sessions', id => $id );

        +

        Delete a session + $session->delete();

        +

        Cleanup old sessions, takes argument of number of seconds old. + $session->cleanup ( 5000 );

        +

        +

        +
        +

        TODO

        +

        * Integrate SQL interface into flatfile interface.

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/TempTable.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/TempTable.html new file mode 100644 index 0000000..e6e2e5c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Session/TempTable.html @@ -0,0 +1,313 @@ + + + + +GT::Session::TempTable - A session management module, subclassing GT::Session::SQL providing temp table support + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Session::TempTable - A session management module, subclassing GT::Session::SQL providing temp table support

        +

        +

        +
        +

        SYNOPSIS

        +

        Create a session: + my $session = new GT::Session::TempTable({ + db => GT::SQL->new( '/path/to/defs' ), + def_path => '/path/to/defs', + create_session => \&create_table_sub + });

        +

        Create temp table controller table. (do once before using this module) + $session->initial_create();

        +

        Create a new temp table: + my ( $GT_SQL_Table_ref, $tmp_id ) = $session->new_set();

        +

        Get the GT::SQL::Table ref to a previous table: + my $GT_SQL_Table_ref = $session->get_set( $tmp_id );

        +

        List all the sets for current session: + my $href = $session->list_sets();

        +

        Save data with the session: + $session->data (``Save this information!'');

        +

        Load a session. + my $session = new GT::Session::TempTable ( $id ) or die ``Can't load session: '$id'.''

        +

        Delete a session: + $session->delete();

        +

        Delete a table set: + $session->delete_set( $tmp_id );

        +

        Cleanup old sessions, takes argument of number of seconds old. + $session->cleanup ( 5000 );

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket.html new file mode 100644 index 0000000..4e54617 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket.html @@ -0,0 +1,623 @@ + + + + +GT::Socket - A simple internet socket handling interface + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Socket - A simple internet socket handling interface

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Socket;
        +
        +    my $sock = GT::Socket->open({
        +        host => 'www.gossamer-threads.com',
        +        port => 80
        +    });
        +
        +    $sock->write("GET / HTTP/1.0\n\n");
        +
        +    print "REQUEST RETURNED:\n\n", $sock->gulpread(-1);
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Socket provides a simple interface for tcp client/server socket services.

        +

        +

        +

        Method List

        +

        Object Creation

        +
        +    open()        Creates a new client socket
        +    server()      Creates a new server socket
        +

        Reading and Writing

        +
        +    write()       Sends all or up to max_up bytes of data to remote
        +    read()        Receives an amount or max_down bytes of data from remote
        +    gulpread()    Gets all or up to max_down bytes of data from remote
        +

        Socket Administration

        +
        +    close()       Closes the socket
        +    EOF()         Returns open/closed status of socket
        +    autoflush()   Sets the socket so that no data is buffered
        +    vec()         Sets bits in a bitmask for select calls
        +    pending()     Returns true if data/clients awaiting
        +    fh()          Returns the raw socket handle
        +

        Server Handling

        +
        +    accept()      Accepts a incoming client request
        +

        +

        +

        Creating a new Client Socket

        +

        To instantiate a new Client Socket connection, the open() method must be +called.

        +
        +    my $sock = GT::Socket->open({
        +        host => 'hostname', # hostname/ip to connect to
        +        port => 1234,       # port to connect to
        +        max_down => 0,      # maximum number of bytes to download (optional)
        +        max_up => 0,        # maximum number of bytes to upload (optional)
        +        timeout => 10       # maximum time to wait for host connect (optional)
        +    });
        +

        The parameters are somewhat flexible, to connect to www.gossamer-threads.com on +port 80, any of the following calling methods can be used.

        +
        +    my $sock = GT::Socket->open({
        +        host => 'www.gossamer-threads.com', 
        +        port => 80  
        +    });
        +
        +    my $sock = GT::Socket->open(
        +        host => 'www.gossamer-threads.com', 
        +        port => 80 
        +    );
        +
        +    my $sock = GT::Socket->open('www.gossamer-threads.com', 80);
        +
        +    my $sock = GT::Socket->open('www.gossamer-threads.com:80');
        +

        Note that as port 80 is the HTTP port, and port gets tested and handled with +the getservbyname function, the following can be done:

        +
        +    # 'http' here but can be 'pop3', 'telnet', etc. depending on service wanted
        +    my $sock = GT::Socket->open('www.gossamer-threads.com', 'http');
        +

        Note that if the value passed to open() is a hash ref, with a host and port, a +handful of other options may be set.

        +

        +

        +

        Limiting maximum amount of data downloaded

        +

        This affects the $sock->read() and the $sock->gulpread() methods.

        +

        The option 'max_down' can be used to put a cap on the number of bytes recieved +through the socket.

        +

        For example to limit the number of bytes downloaded to 2k, set max_down to 2048

        +
        +    my $sock = GT::Socket->open(
        +        host => 'www.gossamer-threads.com',
        +        port => 80,
        +        max_down => 2048
        +    );
        +

        WARNING, once the download maximum has been reached, the socket is closed. Then +no more information can be uploaded to the remote host.

        +

        +

        +

        Limiting maximum amount of data uploaded

        +

        The option 'max_up' is used to limit the number of bytes that can be sent to +the remote host.

        +

        After the maximum number of bytes is hit, the object will no longer carry out +$sock->write() requests.

        +

        This does not affect the number of bytes that can be downloaded. Until max_down +is hit or the remote host finishes the transmission, the socket will keep +listening.

        +

        In the following example. The maximum number of bytes for both download and +upload have been set to 2K.

        +

        Keep in mind, with this example, if the maximum download limit is reached +before the maximum upload, the socket will be closed so the remote server will +stop responding to $sock->write() as well!

        +
        +    my $sock = GT::Socket->open(
        +        host => 'www.gossamer-threads.com',
        +        port => 80,
        +        max_down => 2048,
        +        max_up => 2048
        +    );
        +

        +

        +

        Limiting time taken to connect to a host

        +

        When the module tries to connect to a host, if the host is not running or +simply not present, it may take over 30 seconds for the connect call to give +up.

        +

        The 'timout' option allows the forcing the waiting period to be a certain +number of seconds. By default, the value is set to 10 seconds.

        +

        Since this uses alarm, it will not function on Win32 machines.

        +

        With the following example, the module will spend a maximum of 3 seconds trying +to connect to www.gossamer-threads.com.

        +
        +    my $sock = GT::Socket->open( 
        +        host => 'www.gossamer-threads.com', 
        +        port => 80,
        +        timeout => 3
        +    );
        +

        +

        +

        Methods

        +

        The following methods are available to the Client object

        +

        +

        +

        autoflush ( flag BOOLEAN )

        +
        +    $sock->autoflush(1) # turn on flushing
        +    $sock->autoflush(0) # turn off flushing
        +

        Turns off buffering for the socket. By default, the socket is +autoflushed/buffering turned off.

        +

        This prevents peculiar errors like stalling when trying to communicate with +http servers.

        +

        +

        +

        close

        +

        Closes the socket if open.

        +

        +

        +

        EOF

        +

        Returns true of the socket is closed.

        +

        +

        +

        fh

        +

        Returns the filehandle.

        +

        The return value is file glob, because of this, the upload/download limits +cannot be enforced and the accounting can fall to bits of both the object and +the file glob are being used simultaneously.

        +

        +

        +

        gulpread ( tics INTEGER )

        +

        Attempts to read all the data it can into a buffer and return. If max_down is +non zero, it will read till the remote closes or the limit has been reached and +returns.

        +

        Tics is a non-zero value that will determine how long the function will run for +or wait:

        +
        +    $tics     Action
        +    ----------------------------------------
        +    >0        Wait $tics seconds till returning with results
        +    0         Don't wait, simply get what's there and return
        +    <0        Block, wait until all the data (up to max_down) has been received
        +

        +

        +

        pending ( tics INTEGER )

        +

        Returns true if socket has data pending to be received. Usually this would be +followed with a call to $sock->gulpread() or $sock->read()

        +
        +    $tics     Action
        +    ----------------------------------------
        +    >0        Wait $tics seconds till returning with results
        +    0         Don't wait, simply get what's there and return
        +    <0        Block, wait until all the data (up to max_down) has been received
        +

        +

        +

        read ( number_bytes INTEGER )

        +

        Reads a max of number_bytes from the socket or up to max_down and returns the +result. This is nonblocking so it is possible to get no data or less than the +requested amount.

        +

        +

        +

        vec ( [ bits SCALAR ] )

        +

        Sets the bits appropriate for the object's socket handle. The returned value +can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.

        +

        To test a series of socket handles, vec accepts an already set bit list from +another vec call.

        +
        +    $bits = $sock1->vec();
        +    $bits = $sock2->vec($bits);
        +    $bits = $sock3->vec($bits);
        +

        And $bits can now be used to test on all three handles.

        +

        +

        +

        write ( buffer SCALAR )

        +

        Takes the buffer and send it into the socket or up to the max_up limit.

        +

        Returns the number of bytes sent.

        +

        +

        +

        Creating a new Server Socket

        +

        Creating a server socket is almost identical to creating a client socket except +no hostname is specified. +

        +
        +
        +    my $server = GT::Socket->server({
        +        port => 1234,  # port to host services
        +        max_down => 0, # maximum number of bytes to download (optional)
        +        max_up => 0,   # maximum number of bytes to upload (optional)
        +        timeout => 10  # maximum time to wait for host connect (optional)
        +    });
        +

        The only option that affects the server directly is the port. The optional +values, max_down, max_up, and timeout are passed on to the child socket when +the server accepts a new connection.

        +

        +

        +

        Methods

        +

        The following methods are available to the Client object

        +

        +

        +

        accept

        +

        Accepts an incoming connection and returns a GT::Socket client object for +further interations with the client.

        +

        +

        +

        fh

        +

        Returns the filehandle.

        +

        +

        +

        pending ( tics INTEGER )

        +

        Returns true if server has awaiting connections. Usually this would be followed +with a call to $server->accept();

        +
        +    $tics     Action
        +    ----------------------------------------
        +    >0        Wait $tics seconds till returning with results
        +    0         Don't wait, simply get what's there and return
        +    <0        Block, wait until all the data (up to max_down) has been received
        +

        +

        +

        vec ( [ bits SCALAR ] )

        +

        Sets the bits appropriate for the object's socket handle. The returned value +can be used in select(RBITS,WBITS,EBITS,TIMEOUT) function calls.

        +

        To test a series of socket handles, vec accepts an already set bit list from +another vec call.

        +
        +    $bits = $sock1->vec();
        +    $bits = $sock2->vec($bits);
        +    $bits = $sock3->vec($bits);
        +

        And $bits can now be used to test on all three handles.

        +

        +

        +
        +

        EXAMPLES

        +

        +

        +

        Server

        +
        +    use GT::Socket;
        +
        +    my $server = GT::Socket->server({
        +        port => 7890
        +    });
        +
        +    while (1) {
        +        if ($server->pending(-1)) {
        +            print "Accepting a connection\n";
        +            my $sock = $server->accept();
        +            $sock->write("The time is: " . localtime() . "\n");
        +        }
        +    }
        +

        +

        +

        Client for Server

        +
        +    use GT::Socket;
        +
        +    my $client = GT::Socket->open("localhost:7890");
        +    print "Server Said: ", $client->gulpread(-1);
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Socket.pm,v 1.43 2004/08/23 20:07:44 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket/Client.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket/Client.html new file mode 100644 index 0000000..a6d6896 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Socket/Client.html @@ -0,0 +1,531 @@ + + + + +GT::Socket::Client - Socket module designed for TCP clients + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Socket::Client - Socket module designed for TCP clients

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Socket::Client qw/:crlf/;
        +
        +    my $socket = GT::Socket::Client->open(
        +        host => "gossamer-threads.com",
        +        port => "shell", # AKA port 514
        +        timeout => 10
        +    ) or die GT::Socket::Client->error;
        +
        +    # $socket is now a socket connected to the host. Use
        +    # it as you would use any socket.
        +    $sock->readline(my $line);
        +    print "Read this line from the socket: $line";
        +    print $sock "That line" . CRLF;
        +
        +    $sock->readblock(my $block, 4096);
        +    print "Read 4KB from the socket: $block";
        +    print $sock "QUIT" . CRLF;
        +
        +    $sock->readall(my $all);
        +    print "Everything else from the socket: $all";
        +    print $sock "Something else" . CRLF;
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is a basic socket module that is designed to only handle basic +socket connection and simple read capabilities. Anything else that you want to +do with the socket is entirely up to you - this doesn't try to support +superfluous options that only a few connections will ever use, or options that +should be done in the code using this module instead of the module itself. See +the GT::WWW::http and GT::WWW::https modules for a good working example.

        +

        By default, GT::Socket::Client exports nothing, however it can export the LF, +CR, CRLF, $LF, $CR, and $CRLF constants, individually, or together via the +':crlf' export tag.

        +

        +

        +
        +

        METHODS

        +

        +

        +

        open

        +

        Takes a hash (not hash reference) of socket options, as follows:

        +
        +
        host + +
        +

        [REQUIRED] The name or IP of the host to connect to.

        +
        + +
        port + +
        +

        [REQUIRED] The numeric value (25) or service name (``smtp'') of the port to +connect to.

        +
        + +
        ssl + +
        +

        [OPTIONAL] If this option is provided, the connection will use SSL. Note that +this requires the Net::SSLeay module.

        +
        + +
        timeout + +
        +

        [OPTIONAL] A connection timeout period, in integral seconds. Note that this is +only supported on systems that support the alarm() function; on other systems +(such as Windows), this argument has no effect.

        +
        + +
        non_blocking + +
        +

        [OPTIONAL] Before returning it to you, the connected socket will be set up as +non-blocking if this option is enabled. Note that this option DOES NOT WORK +with the ssl option, due to the Net::SSLeay interface.

        +
        + +
        autoflush + +
        +

        [OPTIONAL] Before returning to you, the connected socket will be made non- +buffering. If you want your socket to be buffered, pass in autoflush with a +false value.

        +
        + +
        ssl + +
        +

        [OPTIONAL] GT::Socket::Client has the ability to establish an SSL connection to +a server for protocols such as HTTPS, SMTPS, POP3S, IMAPS, etc. Note that it +currently has a limitation of not being able to change to or from an SSL +connection once the connection is established, for protocols like FTPS.

        +
        + +
        debug + +
        +

        [OPTIONAL] If debugging is enabled, internal warnings (such as invalid port, +unresolvable host, connection failure, etc.) will be warn()ed. This does not +affect the error() method, which will always be set to the error message when +a problem occurs. Provide a true value if you want the warn()s to appear.

        +
        + +
        +

        +

        +

        readline

        +

        This method reads a single line from the socket. It takes one argument, which +must be a scalar which will be set to the line read. See the eol() method, +which allows you to specify an EOL character other than ``\012''. Note that on a +blocking socket, this will block until it can read a full line (or the server +closes the connection). On a non-blocking socket, the amount of time it will +wait for input is dependent on the value of the read_wait() method.

        +

        1 is returned on success, undef on failure.

        +

        +

        +

        readblock

        +

        This method attempts to read a certain number of bytes from the server. This +takes two arguments: like readline(), the first argument is a scalar that will +be set to the data read. The second argument is the amount of data that may be +read. Note that on a blocking socket, this will block until the required +amount of data is read, or the socket is closed. On a non-blocking socket, this +will return once the requested amount of data is read, the socket closes, or +there is no input for read_wait seconds (See read_wait).

        +

        Note that a block size of -1 makes the socket read until the connection is +closed, in the case of blocking sockets, or until the read_wait() is hit.

        +

        The number of bytes read is returned on success, undef on failure.

        +

        +

        +

        readall

        +

        A synonym for $obj->readblock($_[0], -1) - in other words, it reads all +available data (waiting for up to read_wait seconds, if non-blocking).

        +

        +

        +

        readalluntil

        +

        A useful function for non-blocking sockets (completely useless for blocking +sockets, on which it simply becomes a readall call). Basically, this works +like readall(), above, but it will terminate immediately if it encounters a +pattern that you provide on the end of the data read. Note that this does NOT +work as a delimiter, but is useful for protocols such as POP3 when you want to +read as much as you can, but know what should be at the end of what you read. +The sole advantage of this is that it allows you to avoid the read_wait timeout +that would otherwise be required at the end of a data stream.

        +

        It takes two arguments - the first is a string or array reference of strings +containing the trailing string data. The second is a scalar that will be set +to the data read. For example, for POP3 you might use: "\n.\r\n". You can +optionally pass in a third argument, which is used during the first read - if +the result of the first read is equal to the string passed in, it's returned. +Using the POP3 example again, this might be ".\r\n" - to handle an empty +response.

        +

        +

        +

        select_time

        +

        [Non-blocking sockets only] This adjusts the number of seconds passed to +select() to poll the socket for available data. The default value is 0.05, +which should work in most situations.

        +

        +

        +

        read_wait

        +

        [Non-blocking sockets only] This method is used to set the wait time for reads. +On a local or very fast connection, this can be set to a low value (i.e. 0.1 +seconds), but on a typical slower internet connection, longer wait times for +reading are usually necessary. Hence, the default is a wait time of 5 seconds. +In effect, an attempt to read all data will end after nothing has been received +for this many seconds.

        +

        +

        +

        write

        +

        Sends data to the server. Takes the data to send. This does The Right Thing +for either non-blocking or blocking sockets.

        +

        +

        +

        eol

        +

        This method takes one or more character, and uses it for the EOL character(s) +used by readline. If called without any argument, the EOL character for the +current object is returned.

        +

        +

        +

        error

        +

        If an error (such as connection, socket, etc.) occurs, you can access it via +the error() method. This can be called as either a class or instance method, +since open() return undef instead of an object if the connection fails.

        +

        +

        +

        iaddr

        +

        Once a connection has been established, you can call this method to get the +iaddr value for the connection. This value is as returned by +Socket.pm's inet_aton function.

        +

        +

        +

        port

        +

        Once a connection has been established, this method can be used to determine +the port connected to. Note that this is not necessarily the same as the value +of the port option passed to open() - the return value of this function will +always be numeric (e.g. 25), even if a service name (e.g. "smtp") was +passed to open().

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Socket manpage - A socket module made for Links SQL.

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Client.pm,v 1.16 2005/09/19 23:06:25 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Tar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Tar.html new file mode 100644 index 0000000..d48cb94 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Tar.html @@ -0,0 +1,443 @@ + + + + +GT::Tar - Perl module to manipulate tar files. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Tar - Perl module to manipulate tar files.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Tar;
        +    my $tar = GT::Tar->open('foo.tar');
        +    $tar->add_file( '/path/to/file' );
        +    $tar->write;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Tar provides an OO intefrace to a tar file. It allows you to create or edit +tar files, and if you have Compress::Zlib installed, it allows you to work with +.tar.gz files as well!

        +

        +

        +

        Creating a tar file

        +

        To create a tar file, you simply call:

        +
        +    my $tar = GT::Tar->new('filename.tar');
        +

        and then to save it:

        +
        +    $tar->write;
        +

        will save the tar file and any files you have added.

        +

        +

        +

        Opening an existing tar file

        +

        To open a tar file you call:

        +
        +    my $tar = GT::Tar->open('/path/to/file.tar')
        +        or die "Can't open: $GT::Tar::error";
        +

        Note: the tar object keeps an open filehandle to the file, so if you are on +windows, you may not be able to manipulate it until you call $tar->close_tar, or +the tar object goes out of scope.

        +

        +

        +

        Untarring a tar file

        +

        To untar a tar file, you can simply call:

        +
        +    $tar->untar( \&code_ref );
        +

        or as a class method

        +
        +    GT::Tar->untar('/path/to/tar.tar', \&code_ref );
        +

        The code ref is optional. If provided, you will get passed in the a +GT::Tar::Part object before the file is extracted. This lets you change the +path, or alter any attributes of the file before it is saved to disk.

        +

        Alternatively, instead of a code reference you may pass an extraction path - if +passed, all files will be extracted relative to that path.

        +

        +

        +

        Adding files to a tar file

        +

        To add a file:

        +
        +    $tar->add_file( '/path/to/file' );
        +

        Note, if you add a directory, the tar module will recurse and add all files in +that directory.

        +

        To add a file that isn't saved:

        +
        +    $tar->add_data( name => 'Filename', body => 'File body' );
        +

        You can pass in either a scalar for the body, or an opened file handle.

        +

        +

        +

        Getting a list of files in a tar

        +

        To get a list of files in a tar:

        +
        +    my $files = $tar->files;
        +

        This returns an array ref of GT::Tar::Part objects. See below for how to access +information from a part.

        +

        Note: if you change a part, it will update the tar file if you save it.

        +

        +

        +

        Getting an individual file from a tar

        +

        If you know the name of the file you want:

        +
        +    my $file = $tar->get_file('Filename');
        +

        will return a single GT::Tar::Part object.

        +

        +

        +

        Removing a file from a tar

        +

        To remove a file, you need to know the name of it:

        +
        +    $tar->remove_file('Filename');
        +    $tar->write;
        +

        and you need to save it before the change will take affect.

        +

        +

        +

        GT::Tar::Part

        +

        Each file is a separate part object. The part object has the following +attributes:

        +
        +    name    file name
        +    mode    file permissions
        +    uid     user id
        +    gid     group id
        +    size    file size
        +    mtime   last modified time
        +    type    file type
        +    body    file body
        +

        You can access or set any of these attributes by just using the attribute name +as the method (as it inherits from the GT::Base manpage).

        +

        You can also call:

        +
        +    $file->write;
        +

        or:

        +
        +    $file->write("/extraction/path")
        +

        and the file will be created with the given attributes. Basically untar just +foreach's through each of the objects and calls write() on it.

        +

        +

        +
        +

        EXAMPLES

        +

        To create a new tar and add two directories to it, and save it in +'/tmp/foo.tar';

        +
        +    my $tar = GT::Tar->new('/tmp/foo.tar');
        +    $tar->add_file( '/home/httpd/html' );
        +    $tar->add_file( '/home/backup' );
        +    $tar->write;
        +

        To open an existing tar file and save all the .pl files in /home/alex.

        +
        +    my $tar = GT::Tar->open('files.tar');
        +    my $files = $tar->files;
        +    foreach my $file (@$files) {
        +        my $name = $file->name;
        +        if ($name =~ m,[^/]*\.pl$,) {
        +            $file->write("/home/alex");
        +        }
        +    }
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Tar.pm,v 1.57 2006/08/28 23:17:11 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/TempFile.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/TempFile.html new file mode 100644 index 0000000..67d0052 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/TempFile.html @@ -0,0 +1,340 @@ + + + + +GT::TempFile - implements a very simple temp file. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::TempFile - implements a very simple temp file.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $file = new GT::TempFile;
        +    open (FILE, "> $file");
        +    print FILE "somedata";
        +    close FILE;
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::TempFile implements a very simple temp file system that will remove +itself once the variable goes out of scope.

        +

        When you call new, it creates a random file name and looks for a +tmp directory. What you get back is an object that when dereferenced +is the file name. You can also pass in a temp dir to use:

        +
        +    my $file = new GT::Tempfile '/path/to/tmpfiles';
        +

        Other option you may use are: + my $file = new GT::TempFile( + destroy => 1, + prefix => '', + tmp_dir => '/tmp' + );

        +

        When the object is destroyed, it automatically unlinks the temp file +unless you specify destroy => 0.

        +

        prefix will be prepended to the start of all temp files created +and the lock directory that is created. It is used to keep programs +using the tempfile module that do not have the temp files destroyed +from clashing.

        +

        tmp_dir is the same as calling new with just one argument, it is +the directory where files will be stored.

        +

        TempFile picks a temp directory based on the following:

        +
        +    1. ENV{GT_TMPDIR}
        +    2. ~/tmp
        +    3. ENV{TMPDIR}, ENV{TEMP}, ENV{TMP}
        +    4. /usr/tmp, /var/tmp, c:/temp, /tmp, /temp, 
        +       /WWW_ROOT, c:/windows/temp, c:/winnt/temp
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: TempFile.pm,v 1.36 2005/03/23 04:27:26 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template.html new file mode 100644 index 0000000..29b25a2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template.html @@ -0,0 +1,590 @@ + + + + +GT::Template - Gossamer Threads template parser + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Template - Gossamer Threads template parser

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Template;
        +    my $var = GT::Template->parse('file.txt', { key => 'value' });
        +    ...
        +    print $var;
        +

        or

        +
        +    use GT::Template;
        +    GT::Template->parse_print('file.txt', { key => 'value' });
        +

        or

        +
        +    use GT::Template;
        +    GT::Template->parse_stream('file.txt', { key => 'value' });
        +

        or

        +
        +    use GT::Template;
        +    my $parser = GT::Template->new;
        +    $parser->parse('file.txt', { key => 'value' });
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Template provides a simple way (one line) to parse a template (which +can be either a file or a string) and make sophisticated replacements.

        +

        It supports simple replacements, conditionals, function calls, including other +templates, and more.

        +

        Additionally, through using pre-compiled files, subsequent parses of a template +will be very fast.

        +

        +

        +

        Template Syntax

        +

        The template syntax documentation has moved - it is now documented in +the GT::Template::Tutorial manpage.

        +

        +

        +

        parse

        +

        This option parses a template, and returns the value of the parsed template. +See Parse Options for a description of the possible parse parameters.

        +

        +

        +

        parse_print

        +

        This option parses a template, and prints it. See Parse Options for a +description of the possible parse_print parameters.

        +

        +

        +

        parse_stream

        +

        This option parses a template, and prints each part of it as the parse occurs. +It should only be used in situations where streaming content is required as it +is measurably slower than the parse_print alternative. See Parse Options +for a description of the possible parse_stream parameters.

        +

        +

        +

        Parse Options

        +

        +

        +

        Filename

        +

        The first argument to parse()/parse_print()/parse_stream() (hereafter referred +to simply as parse()) is the full or relative (to the current working +directory) path to the file to parse.

        +

        +

        +

        Variables

        +

        The second argument is a hash reference of template variables that will be +available in the parsed template (see the GT::Template::Tutorial manpage). Arbitrary +hash/array data structure access is supported (see +Advanced variables using references in the GT::Template::Tutorial manpage).

        +

        Loops are supported by providing an array reference or code reference as a +value; array reference loops are generally preferred as they enable the loop to +be used multiple times and support the <%loopvar.length%> syntax.

        +

        +

        +

        Options

        +

        The third argument (which is not required) takes additional options that change +the way a parse is performed. The available options (there are more, however +their use is discouraged) are as follows.

        +
          +
        • string => $template + +

          Passing in string => $template will use $template as for the template +content instead of reading the file specified as the first parse() argument. +If provided, the first argument to parse() (the filename) is ignored.

          +
        • +
        • compress => 1 + +

          Setting compress => 1 will compress all white space generated by the program. +This is usually acceptable for HTML, reducing page sizes by typically 10-20%, +but should not be used for non-HTML templates. The default is 0 (no +compression). This option has no effect when using parse_stream().

          +
        • +
        • strict => 0 + +

          If set to 1, attempting to use a tag that does not exist will display an +``Unknown tag 'tagname''' error. If strict is set to 0, using an unset tag will +not display anything.

          +
        • +
        • escape => 1 + +

          If enabled, this option will cause all variables to be HTML escaped before +being included on a page. Enabling this option is strongly recommended. +all variables before they are printed. Tag values that should not be escaped +should be passed as scalar references (\$foo or \'<html>').

          +

          This option currently defaults to 0, but may eventually change to 1 - so +passing an explicit 1 or 0 value is strongly recommended.

          +
        • +
        • disable => { ... } + +

          This can be used to disable certain GT::Template functionality. To disable a +particular feature, the hash reference passed to disable should contain a +feature_name with a 1 value, unless otherwise indicated. Feature names +are as follows:

          +
            +
          • functions + +

            This can be used to disable Package::function calls, such as +<%Some::Package::function%>. Note, however, that this does _not_ +disable aliased function calls (see below).

            +
          • +
          • function_args + +

            This disables any function calls that specify arguments - for instance, +<%Some::Package::function(1)>. Note that this does _not_ disable +passing arguments to aliased function calls (see below).

            +
          • +
          • function_restrict + +

            This can be used to restrict function calls by limiting the available +functions. It takes a regular expression as an argument, which will be tested +against the fully qualified function name - any function that does not match +the regular expression will not be called. For example, to only allow +functions in 'Package::One' and 'Second::Package' to be called, you could use:

            +
            +    function_restrict => '^(?:Package::One|Second::Package)::\w+$'
            +

            Like the above options, this does not restrict aliased function calls.

            +
          • +
          • coderefs_args + +

            This can be specified to disable the calling of code reference variables with +arguments. Tags such as <%coderefname%> and +<%coderefname()%> will be allowed, but <%coderefname(1)%> +will not.

            +
          • +
          • alias_args + +

            This option can be used to disable the passing of arguments to aliased function +calls (see below).

            +
          • +
          • core_functions + +

            Disables the use of core perl function wrappers such as substr and sprintf.

            +
          • +
          +
        • pkg_chop + +

          When calling a function such as <%Package::A::B::function%>, GT::Template will +first attempt to load Package/A/B.pm, then, if it fails, Package/A.pm, and so +on down to Package.pm, looking for Package::A::B::function in each file. This +behaviour is slow and often undesirable - it is recommended to properly split +up packages (that is, putting Package::A::B inside Package/A/B.pm instead of +Package/A.pm or Package.pm). The ``package chopping'' occurs if pkg_chop is set +to 1 (currently the default, but may change), and does not occur if pkg_chop is +set to 0 (recommended, but not the default for historic reasons).

          +
        • +
        • heap + +

          If this is set, it will be added to the end of any other arguments passed to +functions called.

          +
        • +
        • func_code + +

          When calling a function such as <%Package::function%>, you can override the +default behaviour of simply calling the function by providing a code reference +to func_code. Instead of calling Package::function(), your code reference +will be called with the string of the package to call (e.g. +'Package::function') and the arguments that would have been passed to the +function. The return value of your code will be used as if it was the return +value from the real function.

          +
        • +
        • begin + +
        • end + +

          begin and end can be used to change the characters that start and end a +template tag. These default to <% for begin, and %> for +end. For example, if you changed begin to [* and end to *], you +would use [*tagname*] for a normal tag, [*-- comment --*] for a comment, +etc.

          +
        • +
        • varinc_allow_path => 0 + +

          If enabled, this option will allow paths to be used in variable based includes.

          +
        • +
        +

        +

        +

        Aliases

        +

        The forth option to parse is an optional hash of aliases to set up for +functions. The key should be the alias name and the value should be the +function to call when the alias is invoked. For example:

        +
        +    print GT::Template->parse(
        +        'file.htm',
        +        { key => 'value' },
        +        { compress => 1 },
        +        { myfunc => 'Long::Package::Name::To::myfunc' }
        +    );
        +

        Now in your template you can do:

        +
        +    <%myfunc('argument')%>
        +

        Which will call Long::Package::Name::To::myfunc.

        +

        +

        +

        vars

        +

        Accessing variables from outside a template can be done by calling the +GT::Template->vars method. For further details, please see +the GT::Template::Vars manpage.

        +

        +

        +

        last_modified

        +

        It is sometimes desirable to know the last modification date of a parsed +template (including includes). For this, the last_modified() method can be +used, subject to some caveats:

        + +

        +

        +
        +

        EXAMPLES

        +

        Parse the string contained in $template, making the 'key' tag available.

        +
        +    my $parsed = GT::Template->parse(undef, { key => 'value' }, { string => $template });
        +

        Parse file.txt, compress the result, and print it. This is equivelant to +print GT::Template->parse(...), but slightly faster.

        +
        +    GT::Template->parse_print('file.txt', { key => 'value' }, { compress => 1 });
        +

        Print the output of the template it as it is parsed, not after entirely parsed. +This will output the same as the above command would without the ``compress'' +option, but is slower (unless, of course, streaming is needed).

        +
        +    GT::Template->parse_stream('file.txt', { key => 'value' });
        +

        Don't display warnings on invalid keys:

        +
        +    GT::Template->parse_print('file.txt', { key => 'value' }, { strict => 0 });
        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Template::Tutorial manpage - Documentation/tutorial for GT::Template template +tags.

        +

        the GT::Template::Vars manpage - Interface for accessing/manipulating template tags from +Perl code.

        +

        the GT::Template::Inheritance manpage - Documentation for GT::Template template +inheritance.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Template.pm,v 2.170 2008/08/22 18:42:17 scottm Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Editor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Editor.html new file mode 100644 index 0000000..6e8b70b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Editor.html @@ -0,0 +1,313 @@ + + + + +GT::Template::Editor - This module provides an easy way to edit templates. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Template::Editor - This module provides an easy way to edit templates.

        +

        +

        +
        +

        SYNOPSIS

        +

        Should be called like:

        +
        +    require GT::Template::Editor;
        +    my $editor = new GT::Template::Editor (
        +                    root        => $CFG->{admin_root_path} . '/templates',
        +                    default_dir => $CFG->{build_default_tpl},
        +                    backup      => 1,
        +                    cgi         => $IN
        +                );
        +    return $editor->process;
        +

        and it returns a hsah ref of variables used for displaying a template editor page.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Editor.pm,v 2.20 2009/05/09 17:28:30 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Inheritance.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Inheritance.html new file mode 100644 index 0000000..60de841 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Inheritance.html @@ -0,0 +1,448 @@ + + + + +GT::Template::Inheritance - Provides GT::Template inheritance/local file +determination. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Template::Inheritance - Provides GT::Template inheritance/local file +determination.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::Template::Inheritance;
        +
        +    my $file = GT::Template::Inheritance->get_path(
        +        file => "foo.htm",
        +        path => "/path/to/my/template/set"
        +    );
        +
        +    my @files = GT::Template::Inheritance->get_all_paths(
        +        file => "foo.htm",
        +        path => "/path/to/my/template/set"
        +    );
        +
        +    my @paths = GT::Template::Inheritance->tree(
        +        path => "/path/to/my/template/set"
        +    );
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::Template::Inheritance provides an interface to accessing files for +GT::Template template parsing and include handling. It supports following +inheritance directories and respects ``local'' template directories.

        +

        +

        +

        Inheritance

        +

        GT::Template inheritance works by looking for a .tplinfo file in the template +directory (or local/.tplinfo, if it exists). In order for the template +directory to inherit from another template directory, this file must exist and +must evaluate to a hash reference containing an inheritance key. The +following is a possible .tplinfo file contents:

        +
        +    {
        +        inheritance => '../other'
        +    }
        +

        The above example would indicate that files in this template set can be +inherited from the ../other path, relative to the current template set +directory. The inheritance directory may also contain a full path.

        +

        +

        +

        Inheriting from multiple locations

        +

        You may also inherit from multiple locations by using an array reference for +the inheritance value:

        +
        +    {
        +        inheritance => ['../other', '/full/path/to/a/third']
        +    }
        +

        With the above .tplinfo file, files would be checked for in the current path, +then ../other, then any of ../other's inherited directories, then in +third, then in any of third's inherited directories.

        +

        Also keep in mind that ``local'' directories, if they exist, will be checked for +the file before each of their respective directories.

        +

        Assuming that the initial template path was /full/path/one, and assuming +that ../other inherited from ../other2, the directories checked would be +as follows:

        +
        +    /full/path/one/local
        +    /full/path/one
        +    /full/path/one/../other/local            # i.e. /full/path/other/local
        +    /full/path/one/../other                  # i.e. /full/path/other
        +    /full/path/one/../other/../other2/local  # i.e. /full/path/other2/local
        +    /full/path/one/../other/../other2        # i.e. /full/path/other2
        +    /full/path/to/a/third/local
        +    /full/path/to/a/third
        +

        +

        +
        +

        METHODS

        +

        All methods in GT::Template::Inheritance are class methods. Each method takes +a hash of options as an argument.

        +

        +

        +

        get_path

        +

        +

        +

        get_all_paths

        +

        These methods are used to obtain the location of the file GT::Template will +use, taking into account all inherited and ``local'' template directories. The +get_path option will return the path to the file that will be included, while +the get_all_paths option returns the path to all copies of the file found in +the local/inheritance tree. Both methods take a hash containing the following:

        +
        +
        file + +
        +

        The name of the file desired.

        +
        + +
        path + +
        +

        The template directory at which to start looking for the above file. Depending +on the existance of ``local'' directories and template inheritance, more than +just this directory will be checked for the file.

        +
        + +
        local + +
        +

        Optional. Can be passed with a false value to override the checking of ``local'' +directories for files.

        +
        + +
        inheritance + +
        +

        Optional. Can be passed with a false value to override the checking of +inheritance directories for files.

        +
        + +
        +

        +

        +

        tree

        +

        This method returns a list of directories that would be searched for a given +file, in the order they would be searched. It takes the path, local, and +inheritance options above, but not the file option.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Template manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Inheritance.pm,v 1.7 2005/02/09 20:51:27 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Tutorial.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Tutorial.html new file mode 100644 index 0000000..3cadfc3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Tutorial.html @@ -0,0 +1,1284 @@ + + + + +GT::Template::Tutorial - Gossamer Threads template syntax documentation + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Template::Tutorial - Gossamer Threads template syntax documentation

        +

        +

        +
        +

        Template Syntax

        +

        At its most basic level, the template parser replaces tags with content. By +default a tag is anything enclosed between <% and %>. For the +purposes of this document, these two values will be assumed.

        +

        +

        +

        Variable Substitution

        +

        At the simplest level of GT::Template templates are simple variable +replacements. For example, consider the following template code:

        +
        +    You are <%age%> years old.
        +

        This would be displayed with '<%age%>' replaced with a value. For example, if +age was given a value of 35, the above would be displayed as:

        +
        +    You are 35 years old.
        +

        A more complex form of variable access is also available, which is covered +later in the +Advanced variables using references +section of this document.

        +

        +

        +

        Sets

        +

        You can set values from within a template by using:

        +
        +    <%set Title = 'Login'%>
        +

        and now <%Title%> will be equal to Login. This is especially useful for +includes, where you could, for example, set a Title variable to a string +that will be displayed in an included template.

        +

        You can also set one variable to the value of another, such as:

        +
        +    <%set title = $return_title%>
        +

        This will set the variable ``title'' with the value of the variable ``return_title.''

        +

        Note that when using `` '' for a string, you may include variables by using the +$variable or ${variable} syntaxes, such as:

        +
        +    <%set title = "A $main_title page: ${secondary_title}Z"%>
        +

        Additionally, the sequence ``\n'', ``\t'', and ``\r'' produce a linefeed character, +tab, and carriage return, respectively. Additionally, a \ may precede any +non-letter/word character to mean just the character:

        +
        +    <%set price_display = "Price:\n\tTotal: \"\$3.40\""%>
        +

        which would set price_display to:

        +
        +    Price:
        +        Total: "$3.40"
        +

        Note that the interpolation of variables and \ escapes do *not* apply when +using 'single quotes' as the string delimiter. In such cases, only \\ and \' +have a special meaning - they are used for a literal \ and ' character.

        +

        +

        +

        Operators

        +

        GT::Template is capable of performing some basic math calculations and one +string-multiple function in templates displaying the results in the parsed template.

        +

        For example, if the 'age' variable is 15, the following tag:

        +
        +    <%age + 10%>
        +

        will display 25 in the template. Besides addition there are the following +operators, which work as expected: + - + * + / + % (remainder) + ^ (raised to the power of)

        +

        The following operators are also worth explaining: +

        +
        +
        +    i/
        +    /N
        +    ~ (Remainder difference)
        +    x (String multiplier)
        +

        i/ performs integral division between the two numbers. For example, '4' i/ 3 +will result in 1, '100' i/ 3 would result in 33, etc.

        +

        /N does not actually use a literal N, instead N should be replaced by a number. +The result will be formatted (and rounded) to N decimal places. For example, +'4' /3 3 would result in: 1.333, while '5' /3 3 would give you: 1.667. +'3' /3 3 would be 1.000.

        +

        Note that i/ and /0 are not the same, as can be illustrated here: +38 i/ '3.8' => 12 - becomes 38 i/ 3 +38 /0 '3.8' => 10 - 38 / 3.8 is calculated, then rounded with 0 decimal place +precision.

        +

        You should be sure of which one you mean to use, or you may end up with +unexpected results.

        +

        ~ is used to get a remainder difference. Where 8 % 5 would return 3, 8 ~ 5 +will return 2. This is calculated as the divisor (5) minus the remainder (3). +This is useful when generating tables in a loop - when you hit the end of the +loop, you want to be able to put an empty cell with a colspan of however many +rows are left. Something like: <%row_num ~ 5%> will give you the proper value.

        +

        As mentioned, there is also one string operator, 'x'. When you use 'x', the +variable (or value as we'll see in a second) will be displayed ``n'' times, where +``n'' is the integral value of the right hand side.

        +

        Assuming that the 'name' variable is 'Jason', this tag:

        +
        +    <%name x 2%>
        +

        will display JasonJason in the parsed template. Like this, it isn't all that +useful because you could simply put <%name%><%name%> in your +template. However, the right hand side may instead use the value of a +variable, such as in this example:

        +
        +    <%name x $print%>
        +

        Assuming that 'name' is still 'Jason', and that 'print' is 3, this would display:

        +
        +    JasonJasonJason
        +

        Though this is useful as is, this is taken a step furthur: the first does not +always have to be a variable. By using 'single quotation marks' or ``double +quotation marks'' we can display fixed text a variable number of times.

        +

        For example:

        +
        +    <%'My Text' x $print%>
        +

        Again assuming that the variable print is 3, this will print: +

        +
        +
        +    My TextMy TextMy Text
        +

        this comes in handy when doing things like indentation.

        +

        The same string quoting interpolation rules mentioned in Sets apply here - +both `` and ' are accepted as delimiters, with different interpolation rules.

        +

        +

        +

        Set modifiers

        +

        You can add, subtract, etc. to your variables with the following syntax:

        +
        +    <%set variable += 3%>
        +

        += can be changed to the following:

        +
        +    += - Adds to a variable
        +    -= - Subtracts from a variable
        +    *= - Multiplies a variable
        +    /= - Divides a variable
        +    %= - Set a variable to a remainder
        +    ^= - Raise a variable to a power
        +    .= - Appends to a string
        +    x= - "Multiplies" a string - "ab" x 3 is "ababab"
        +    ||= - sets a variable if not already set
        +    &&= - sets a variable if already set
        +

        +

        +

        Set + Operators

        +

        You can combine the above operator functions with sets (including sets with modifiers) by simply adding set foo = to the beginning of the operator tag. For example:

        +
        +    <%set foo += 3 * 3%>     # foo is now set to whatever it was, + 9
        +    <%set foo *= 3 + 3%>     # foo has been multiplied by 9
        +    <%set foo = $bar /0 2%>  # foo is now set to half of $bar, rounded to an integer (see /N above)
        +

        +

        +

        Conditionals

        +

        You can use conditionals if, ifnot (or unless), elseif, and else +as in:

        +
        +    <%if age%>
        +        You are <%age%> years old.
        +    <%elseif sex%>
        +        You are <%sex%>.
        +    <%else%>
        +        I know nothing about you!
        +    <%endif%>
        +
        +    <%ifnot login%>
        +        You are not logged in!
        +    <%endif%>
        +
        +    <%unless age%>
        +        I don't know how old you are!
        +    <%endif%>
        +

        If you like you may use elsif instead of elseif (drop the 'e'). +unless and endunless are aliases for ifnot and endif, respectively, +and may be used interchangeably.

        +

        All conditionals must be ended with an endif tag, although may contain any +number of elseif conditionals and/or a single else conditional between +the if and endif tags.

        +

        Conditionals may be nested within each other, to arbitrary depth:

        +
        +    <%if age%>
        +        You are <%age%> years old
        +        <%if sex%>
        +            and you are <%sex%>
        +        <%endif%>
        +    <%endif%>
        +

        +

        +

        Comparisons

        +

        Inside conditionals you can use <, >, <=, >=, +==, !=, lt, gt, le, ge, eq, ne, contains, starts, +and ends. This allows you to do things like:

        +
        +    <%if age == 15%>
        +        You're 15!
        +    <%endif%>
        +

        where the == can be replaced with any operator listed above. If the right hand +side of the equation starts with a '$', the string will be interpolated as a +variable. If you wish to use a string starting with a literal $, you can avoid +this interpolation by adding quotes around the right hand value. The left hand +side is always a variable.

        +

        lt, gt, le, ge, eq, and ne are the alphabetical equivelants +of <, >, <=, >=, ==, and !=, respectively. +In terms of less-than and greater-than comparisons, the comparison is similar +to a dictionary: aa is less than b, but greater than a; 10 is +greater than 1, but less than 2; Z is less than a, due to +capitalization (unless using ilt, ige, etc.). contains will be true +if the variable contains the right-hand side. starts and ends will be +true if the variable starts with, or ends with, respectively, the right-hand +value.

        +

        There are also case-insensitive versions of the string comparisons - they are: +ilt, igt, ile, ige, ieq, ine, icontains, istarts, and +iends. These comparisons work exactly like the versions _without_ the i +except that the comparison is case-insensitive.

        +

        start, istart, end, and iend are aliases for the comparison with an +added s. like and ilike are deprecated aliases for contains and +icontains and should no longer be used.

        +

        +

        +

        Logical Operators

        +

        If statements (including elseif statements) may contain multiple conditions +using one of the two booleans operators or and and. For example:

        +
        +    <%if age and sex and color%>
        +        I know your age, sex and hair color.
        +    <%else%>
        +        I don't have enough information about you!
        +    <%endif%>
        +
        +    <%if age < 10 or age > 90 or status eq banned%>
        +        You are not permitted to view this page.
        +    <%endif%>
        +

        It should be noted that it is currently not possible to mix both or and +and in a single if statement - you may, however, use the same boolean +multiple times in a single statement. (Brackets) are also not currently +supported.

        +

        Internally, if statements will be short-circuited as soon as possible. That +means that for the following tag: + <%if foo = 1 or foo = 2 or foo = 3%> +the following will occur:

        +

        First, variable ``foo'' will be tested to see if it is numerically equal to 1. +If it is, the rest of the checks are aborted since the if will pass regardless. +If it is not, foo = 2 will be checked, and if true, will abort the next check, +and so on until a condition is true or the end of the list of statements is +encountered.

        +

        Likewise with and, except that with and the parser will stop checking as +soon as the first false value is encountered (since a false value means the +entire condition will be false).

        +

        +

        +

        Loops

        +

        Inside your template you can use loops to loop through an array reference, code +reference, or through a fixed set of numbers. If using an array reference, each +element should be either a hash reference or a scalar value, and when using a +code reference every return should be a hash reference or scalar value, or +undef to end the loop. The variables in the hash reference will then be +available for that iteration of the loop, or, if using scalar values, the value +will be available as the <%loop_value%> variable.

        +

        For example:

        +
        +    <%loop people%>
        +        <%if name eq 'Jason'%>
        +            I have <%color%> hair.
        +        <%else%>
        +            <%name%> has <%color%> hair.
        +        <%endif%>
        +    <%endloop%>
        +

        would loop through all values of pens, and for each one would print the +sentence substituting the color of the pen. Also, inside your loop you can use +the following tags:

        +
        +    <%row_num%> - a counter for what row is being looped, starts at 1.
        +    <%rownum%>  - an alias for <%row_num%>
        +    <%first%>   - boolean value that is true if this is the first row, false otherwise.
        +    <%last%>    - boolean value that is true if this is the last row, false otherwise.
        +    <%inner%>   - boolean value that is true if this is not first and not last.
        +    <%even%>    - boolean value is true if row_num is even.
        +    <%odd%>     - boolean value is true if row_num is odd.
        +

        You could use even and odd tags to produce alternating colors like:

        +
        +    <%loop results%>
        +        <tr><td bgcolor="<%if even%>white<%else%>silver<%endif%>">..</td></tr>
        +    <%endloop%>
        +

        Also, you can use <%lastloop%> to abort the loop and skip straight to the +current loop's <%endloop%> tag, and <%nextloop%> to load the next loop +variables and jump back to the beginning of the loop.

        +

        The built-in loop position variables (row_num, first, last, ...) and any +variables set via the loop variable will only be available for the current loop +iteration, after which the variables of the next loop iteration will be set, +or, for variables that exist in one iteration but not the next, the variables +that existed prior to the loop being called will be restored.

        +

        When using array reference-based loops (which are much more common than and +preferred to the alternative code reference-based loops), you can use the +loopvar.length variable which will contain the number of items contained +within the loop.

        +

        To loop through a particular range of numbers, you can use the following syntax:

        +
        +    <%loop 1 to 5%>
        +        ...
        +    <%endloop%>
        +

        This can alternatively be written as:

        +
        +    <%loop 1 .. 5%>
        +        ...
        +    <%endloop%>
        +

        Additionally, either or both of the two values may be a variable, such as:

        +
        +    <%loop $start to $finish%>
        +        ...
        +    <%endloop%>
        +

        Inside the loop, the current value is accessible via the <%loop_value%> +variable, as if you were simply looping over an array of integers. The looping +always occurs in increments of 1, and the start and end values will have any +fractional value truncated.

        +

        You can perform a loop in reverse order by adding the word reverse after loop, +such as:

        +
        +    <%loop reverse loopvar%>...<%endloop%>
        +    <%loop reverse 1 to 5%>...<%endloop%>
        +

        Note, however, that reverse only works on array reference or range loops; when +using code reference loops the order will not be reversed.

        +

        +

        +

        Filters

        +

        Filters can be used to alter the appearance of a tag. The general format of +a filter is:

        +
        +    <%filtername variable%>
        +

        Multiple filternames can be chained together as well, such as:

        +
        +    <%filtername1 filtername2 filtername3 variable%>
        +

        The filter closest to the variable name will be applied first. In the above +example, that means filtername3 will be applied, then +filtername2 applied to the result, then filtername1 applied to that +result.

        +

        The filters available include:

        +
        +
        escape_html + +
        +

        This filter will perform HTML-escaping of the variable. Specifically, +<, >, &, and " are converted to their HTML equivelants +(&lt;, &gt;, &amp;, and &quot;, respectively).

        +
        +
        +

        Assuming that somevar contains the value abc&def"ghi, the following:

        +
        +
        +
        +    <%escape_html somevar%>
        +
        +
        +

        will become:

        +
        +
        +
        +    abc&amp;def&quot;ghi
        +
        +
        +

        If the template parser has escape mode turned on, this would cause variables to +be escaped *twice* -- unless, of course, the variable is passed as a scalar +reference.

        +
        + +
        unescape_html + +
        +

        This filter will unescape the HTML escapes &amp;, &lt;, &gt;, and +&quot; back to their original forms of <, >, &, and ", +respectively.

        +
        + +
        escape_url + +
        +

        When adding a value to a URL is necessary, escape_url can be used to convert +characters other than alphanumeric (a-z, A-Z, 0-9) ., and <-> to the +URL-escaped %XX form (where XX is a two-digit hexadecimal value).

        +
        +
        +

        For example, if you want to use the tag <%name%> in a URL, it is +recommended to instead use <%escape_url name%>. In particular, this +avoids the possibility of the CGI parameters being passed incorrectly when a +variable contains letters such as ?, ;, =, etc.

        +
        + +
        unescape_url + +
        +

        This filter performs the opposite of escape_url - that is, any sequence of +%XX, where XX is any two hexadecimal characters, and the + character +will be converted to the appropriate character - a single space in the case of +the +.

        +
        + +
        escape_js + +
        +

        This filter will safely escape a javascript variable so that it can be used +inside a javascript string delimited with either ``double quotes'' or 'single +quotes'. Specifically, it puts a \ in front of every \, ' and " +character and converts newlines to \n.

        +
        +
        +
        +    var javascriptVariable = '<%escape_js somevar%>';
        +
        + +
        nbsp + +
        +

        This filter will display the variable with all whitespace converted to HTML +non-breaking space escapes (&nbsp;). This is particularly useful when +attempting to display something accurately which may contain spaces, or when +attempting to ensure that a value containing spaces does not wrap over multiple +lines.

        +
        + +
        uc + +
        lc + +
        +

        These filters display the variable with all letters changed to uppercase +(uc) or lowercase (lc).

        +
        + +
        ucfirst + +
        lcfirst + +
        +

        These filters convert the first character of the variable to uppercase +(ucfirst) or lowercase (lcfirst).

        +
        + +
        +

        Some filter examples, assuming the following variables have been set:

        +
        +    var1 => "<html>",
        +    var2 => "test&lt;b&gt;&amp;&lt;/b&gt;two",
        +    var3 => "test't<hr>ee",
        +    fname => "john",
        +    lname => "DOE"
        +

        Examples:

        +
        +    Template code                           --> Becomes
        +    =============                               =======
        +
        +    <tag attr="<%escape_html var1%>">       --> <tag attr="&lt;html&gt;">
        +    <%unescape_html var2%>                  --> test<b>&</b>two
        +    var jsVar = '<%escape_js var3%>';       --> var jsVar = 'test\'three';
        +    <a href="a?f=<%escape_url unescape_html var2">
        +                                            --> <a href="a?f=test%3Cb%3E%26%3C%2Fb%3Etwo">
        +    <a onclick="jsVar = '<%escape_html escape_js var3%>'">
        +                                            --> <a onclick="jsVar = 'test\'t&lt;hr&gt;ee'">
        +

        +

        +

        Includes

        +

        You can include other files. Any tags inside the includes will be evaluated as +if the content of the included file were included in the current file (although +there is one exception: unclosed if tags inside the include will be implicitly +ended). Includes can occur anywhere - inside if statements, for loops, other +includes, etc. The following tag:

        +
        +    <%if info%>
        +        <%include info.txt%>
        +    <%else%>
        +        <%include noinfo.txt%>
        +    <%endif%>
        +

        will include either the file info.txt (if info is true) or noinfo.txt (if info +is false or not set). It must be in the template's root directory which is +defined using $obj->root, or '.' by default.

        +

        A useful application of the include tag is to include files inside a loop, as in:

        +
        +    <%loop people%>
        +        <%include person.txt%>
        +    <%endloop%>
        +

        Another useful example is in including a common header or footer to all pages. +If, for example, you have a header.htm that you wish to be included, but it +needs a variable title, you could combine the include with a set, such +as:

        +
        +    <%set Title = 'Login'%>
        +    <%include header.htm%>
        +

        and then in your header.htm:

        +
        +    <html>
        +        <head>
        +            <title><%Title%></title>
        +        </head>
        +

        This would allow you to have different titles, but still include the same +header template on each page.

        +

        GT::Template also supports including a file based on the value of a variable by +specifying the variable name (starting with a $) for the filename:

        +
        +    <%include $var%>
        +

        This allows for more powerful include abilities. For example, if you wanted +to have a single outer template which includes another, variable template you +could use an outer template (for the purposes of this example, assume this +template is named 'outer.html') something like:

        +
        +    <html>
        +      <head><title><%title%></title></head>
        +      <body>
        +        <div style="border: 5px solid black">
        +          <%include $inner_template%>
        +        </div>
        +      </body>
        +    </html>
        +

        Then, inside other templates, you would do:

        +
        +    abc.html:
        +    =========
        +
        +    <%set inner_template = 'abc_content.html'%>
        +    <%set title = 'ABC'%>
        +    <%include layout.html%>
        +
        +    xyz.html:
        +    =========
        +
        +    <%set inner_template = 'xyz_content.html'%>
        +    <%set title = 'XYZ'%>
        +    <%include layout.html%>
        +

        Now both abc.html and xyz.html would show up with the same page layout defined +in layout.html, with a content section coming from their respective +*_content.html templates.

        +

        If an included template does not exist in the current template set, inherited +template sets will be checked as well. For details on template set +inheritance, see the GT::Template::Inheritance manpage.

        +

        +

        +

        Functions

        +

        You can call functions in either the variable substitution or in the +comparison. The function must reside in a package, and you must do the full +qualification.

        +
        +    A script header normally looks like <%CGI::header%>
        +

        which would call CGI::header(). You can pass arguments to this as in:

        +
        +    A script header normally looks like <%CGI::header('text/html')%>.
        +

        Also, you can pass any currently available template variable to the function +by prefixing it with a $, such as:

        +
        +    <%CGI::header($variable)%>
        +

        Multiple arguments may be passed by comma separating the arguments, as in: + <%Mypackage::mysub($age, 'Title')%>

        +

        If a function returns a hash reference, those values will be added to the +current substitution set. Suppose you have a function:

        +
        +    package Mypackage;
        +    sub load_globals {
        +        ..
        +        return { age => 15, color => red };
        +    }
        +

        You could then do:

        +
        +    <%Mypackage::load_globals%>
        +    You are <%age%> years old, with <%color%> hair!
        +

        Functions are loaded while parsing, so calling the function with different +arguments (to set your variables to different values) is possible.

        +

        Since package names can make functions rather long and ugly, you can call +->parse() with an ``alias'' key in the options hash. This key should contain +shortcut => function pairs. For example, if you want to call Foo::Bar::blah() +in your template, you could pass: asdf => 'Foo::Bar::blah', and when <%asdf%> +or <%asdf(...)%> is encountered, Foo::Bar::blah will be called.

        +

        +

        +

        Comparisons with Functions

        +

        You can combine use a function for an if/elseif statement value, as in:

        +
        +    <%if age == My::years_old%>
        +        You are the same age as me!
        +    <%endif%>
        +

        which would call My::years_old() and compare the return value to the value of +the ``age'' variable.

        +

        +

        +

        Sets with Functions

        +

        You may use a function call as the value of a ``set'' instruction to set a +template variable based on the return value of the function. The following +code will set a variable named ``age'' to the return value of Mypackage::age():

        +
        +    <%set age = Mypackage::age%>
        +

        Arguments passed are the same as the arguments to a regular function.

        +

        +

        +

        Core Functions

        +

        A limited number of core Perl functions are available to be used in templates. +Currently, substr(), length(), sprintf(), index(), rindex(), rand(), and +reverse() can be called as functions from within a template. For example:

        +
        +    <%set test = "abcdefg"%>
        +    <%substr($test, 0, 3)%>
        +

        outputs abc. See the respective entries in perldoc perlop for +documentation on using these functions.

        +

        +

        +

        Comments

        +

        Comments can be used to add comments about a template, or comment out existing +sections of template code. Comments start with the template opening tag +followed by -- (typically <%--) and end with -- followed by the +template closing tag (typically --%>). Additionally, comments may +contain other template tags, including other comments.

        +

        A simple comment:

        +
        +    <%-- This is a comment, and will not be displayed --%>
        +

        A comment example demonstrating included tags and nested comments:

        +
        +    <%--
        +      <%template_tag%>
        +      <%-- This is a comment, and will not be displayed <%-- another comment --%>--%>
        +      <%if test%>example<%endif%>
        +    --%>
        +

        +

        +

        Advanced variables using references

        +

        A more complex form of variable access is available which allows you to access +values contained within hash and/or array reference variables. These variables +can be used anywhere ordinary variables are permitted - including sets.

        +

        For example, assume a variable named ``person'' has been passed to the template +parser with a value of:

        +
        +    {
        +        name => "John Doe",
        +        age => 35,
        +        hair => "brown"
        +    }
        +

        The following example:

        +
        +    <%person.name%> is <%person.age%> and has <%person.hair%> hair.
        +

        Would display:

        +
        +    John Doe is 35 and has brown hair.
        +

        Arrays are accessed in exactly the same way, using the array index (starting +from 0). Assume for the following example that a variable phone has been +provided, with the following value:

        +
        +    ['(555) 555-5678', '(555) 555-6789', '(555) 555-7890']
        +

        The following example:

        +
        +    Primary phone number: <%phone.0%>
        +    Secondary numbers: <%loop phone%><%unless first%><%loop_value%>  <%endunless%><%endloop%>
        +

        Will display:

        +
        +    Primary phone number: (555) 555-5678
        +    Secondary numbers: (555) 555-6789  (555) 555-7890
        +

        Furthurmore, the size of array reference values (such as array reference-based +loops) may be determined by adding .length to the end of the tag. Using the +same ``phone'' value above, the following:

        +
        +    Primary phone number: <%phone.0%>
        +    <%if phone.length > 1%>Secondary numbers: <%loop phone%><%unless first%><%loop_value%>  <%endunless%><%endloop%><%endif%>
        +

        Would display the same content, however if the ``phone'' value contained only a +single value, the ``Secondary numbers'' line would not be displayed at all:

        +
        +    Primary phone number: (555) 555-5678
        +

        You can access the last (or nth last) value of an array reference by using +.last or .lastn. For example, to show the last and 2nd-last secondary +phone numbers, you could use:

        +
        +    <%phone.last%>
        +    <%phone.last2%>
        +

        These correspond directly to the [-1] and [-n] array subscripts in +Perl code.

        +

        Data structures of abitrary depth are supported, and can consist of any +combination of array and hash references.

        +

        Consider the following more complex example, with a people variable set to +the following loop:

        +
        +    [
        +        {
        +            name => "John Doe",
        +            age => 35,
        +            hair => "no",
        +            phone => {
        +                work => "(555) 555-5678",
        +                home => "(555) 555-6789"
        +            }
        +        },
        +        {
        +            name => "Jane Doe",
        +            age => 25,
        +            hair => "brown",
        +            phone => {
        +                work => "(555) 555-5678",
        +                home => "(555) 555-1234"
        +            }
        +        }
        +    ]
        +

        The following template code:

        +
        +    <%loop person%><%row_num%>. <%name%>, <%age%> years of age, <%hair%> hair.  Phone: work: <%phone.work%>, home: <%phone.home%>.
        +    <%endloop%>
        +    The first person on the list, <%person.0.name%>, can be reached at either <%person.0.phone.work%> or <%person.0.phone.home%>.
        +

        Will display:

        +
        +    1. John Doe, 35 years of age, no hair.  Phone: work: (555) 555-5678, home: (555) 555-6789.
        +    2. Jane Doe, 25 years of age, brown hair.  Phone: work: (555) 555-5678, home: (555) 555-1234.
        +
        +    The first person on the list, John Doe, can be reached at either (555) 555-5678 or (555) 555-6789.
        +

        In addition to hash reference support, GT::Config objects and +GT::CGI objects can be accessed as if they were hashes. So with:

        +
        +    config => $gt_config_object,
        +    in => $cgi_object
        +

        The following:

        +
        +    <%config.variable1%>
        +    <%in.parameter1%>
        +

        would access $gt_config_object->{variable1} and +$cgi_object->param('parameter1'). If used in a <%set ...%> +command, the following:

        +
        +    <%set config.variable1 = 4%>
        +    <%set in.parameter1 = 5%>
        +

        would set $gt_config_object->{variable1} to 4, and call +$cgi_object->param('parameter1', '5'), thereby setting it to 5.

        +

        Furthermore, complex variable expressions may contain other variables, such as:

        +
        +    <%set parameter = 'variable1'%>
        +    <%config.$parameter%>
        +

        which would display the same thing as <%config.variable1%>. Note +that complex variables cannot be used here - that is:

        +
        +    <%set abc.def = 'ghi'%>
        +    <%config.$abc.def%>
        +

        will read the value of abc, then access config.(value).def. It is, however, +possible to put a . inside a value, such as:

        +
        +    <%set abc = 'def.ghi'%>
        +    <%config.$abc%>
        +

        would be equivalent to:

        +
        +    <%config.def.ghi%>
        +

        Complex variables can be used inside double quoted strings (wherever +double-quoted strings are accepted) but only in the form ${a.b}. Specifically, +the following:

        +
        +    <%set var1.key1 = 3%><%set var2 = "$var1.key1"%>
        +

        does not actually set var2 to ``3'' - the following achieves the desired effect:

        +
        +    <%set var1.key1 = 3%><%set var2 = "${var1.key1}"%>
        +

        Complex variables containing other variables are also supported, such as:

        +
        +    <%set var1 = "${var1.$keyvar}"%>
        +

        You can create a new, empty hash or array reference from within a template by +assigning the special <%init hash varname%> or +<%init array varname%> syntax.

        +
        +    <%init array array_var%>
        +    <%set array_var.0 = 10%><%set array_var.1 = 11%><%set array_var.2 = 15%>
        +    <%loop array_var%><%loop_value%> <%endloop%>
        +

        produces:

        +
        +    10 11 15
        +

        You can append (push) onto an existing array by assigning to the special array +index ``push'':

        +
        +    <%init array a%>
        +    <%set a.push = 0%><%set a.push = 1%>
        +    <%loop 3 to 15%><%set a.push = $a.last + $a.last2%><%endloop%>
        +    <%loop a%><%loop_value%> <%endloop%>
        +

        produces the first 15 numbers of the Fibonacci sequence:

        +
        +    0 1 1 2 3 5 8 13 21 34 55 89 144 233 377
        +

        +

        +

        Whitespace compression

        +

        Normally, template tags do not affect the whitespace around them, however it is +sometimes desirable or necessary to remove the whitespace immediately before or +immediately after the tag. Consider the following example, which is intended +to print the values in 'values' that are odd and less than 10, separated by +-'s:

        +
        +    <%set found_one = 0%>
        +    <%loop values%>
        +        <%set odd = loop_value % 2%>
        +        <%if loop_value < 10 and odd%>
        +            <%if found_one%>
        +                <%-- We've seen one before, so print the '-' --%>
        +                -
        +            <%else%>
        +                <%-- We haven't seen one, so don't print the '-', but print it next time --%>
        +                <%set found_one = 1%>
        +            <%endif%>
        +            <%loop_value%>
        +        <%endif%>
        +    <%endloop%>
        +

        will actually produce, given a loopvar containing the values 1 through 15, +the following output (where _'s are actually spaces):

        +
        +    
        +    
        +    ____
        +    ____
        +    ________
        +    ____________
        +    ____________
        +    ________
        +    ________1
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    ________
        +    ____________
        +    ____________-
        +    ________
        +    ________3
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    ________
        +    ____________
        +    ____________-
        +    ________
        +    ________5
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    ________
        +    ____________
        +    ____________-
        +    ________
        +    ________7
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    ________
        +    ____________
        +    ____________-
        +    ________
        +    ________9
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +    
        +    ____
        +    ____
        +

        There are, of course, various ways around this - for instance, you could put +all the tags on one line with no spaces between them. However, such an +approach becomes very difficult to look at and use. The alternative is to use +GT::Templates's whitespace compression tags.

        +

        Any tag (including comments) may start or end (or start and end) with a ~ - +if present, leading (if at the beginning of the tag) and/or trailing (if at the +end of the tag) spaces, tabs, and newline characters will be removed. So, you +could change the above code to the following:

        +
        +    <%set found_one = 0 ~%>
        +    <%loop values ~%>
        +    
        +        <%set odd = loop_value % 2 ~%>
        +        <%if loop_value < 10 and odd ~%>
        +            <%if found_one ~%>
        +                <%-- We've seen one before, so print the '-' --~%>
        +                -
        +            <%~ else ~%>
        +                <%-- We haven't seen one, so don't print the '-', but print it next time --~%>
        +                <%set found_one = 1 ~%>
        +            <%endif ~%>
        +    
        +            <%loop_value ~%>
        +        <%endif ~%>
        +    
        +    <%endloop%>
        +

        Assuming the same data, this would give you a result of:

        +
        +    1-3-5-7-9
        +

        The spaces around the tags are not necessary - that is, you could write +<%~tag_name ~%> <%~ tag_name ~ %> <% ~ tagname ~ %> +or any other variants. The style in the example above is used only for +improved readability.

        +

        Note that this option only affects whitespace in the current template, and does +not affect the value of variables or the content of includes. Example:

        +
        +    abc  <%~ varname ~%>  def
        +

        Assuming 'varname' contains the value ' value ', the above will produce the +output:

        +
        +    abc value def
        +

        but not:

        +
        +    abcvaluedef
        +

        Likewise with includes:

        +
        +    abc <%~ include page.html ~%> def
        +

        Assuming page.html contains the following (with a space before ``a'' and after +``z''):

        +
        +     az
        +

        you will get the following output:

        +
        +    abc az def
        +

        or possibly, if the include contains a newline character at the end:

        +
        +    abc az
        +    def
        +

        but not:

        +
        +    abcazdef
        +

        Additionally, you may use the special tag <%~%> to eliminate both +leading and trailing whitespace without needing a tag. For example:

        +
        +    a
        +    <%~%>
        +    b
        +    <% ~ %>
        +    c
        +

        will output:

        +
        +    abc
        +

        +

        +

        Variable Dumping

        +

        Often it is useful to dump the value of all tags available on the current page, +or the value of a single variable. For this, there is a built-in DUMP function +to dump a variable:

        +
        +    <%DUMP%>
        +
        +    <%DUMP variable%>
        +
        +    <%DUMP variable.key%>
        +

        The first example will display a dump of all the tags available wherever the +<%DUMP%> tag is added, while the second and third examples will +display a dump of the 'variable' and 'variable.key' values, respectively.

        +

        DUMP tags should only be used for debugging purposes; they are not intended +to be used on live, publically accessible templates as they may contain +sensitive data that should not be made publically available.

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads, Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Template manpage - for documentation on invoking the template parser.

        +

        the GT::Template::Inheritance manpage - for documentation on template inheritance.

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Tutorial.pod,v 2.17 2006/06/13 18:36:19 jagerman Exp $ + +

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Vars.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Vars.html new file mode 100644 index 0000000..f7f0778 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/Template/Vars.html @@ -0,0 +1,366 @@ + + + + +GT::Template::Vars - Tied hash for template tags handling + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::Template::Vars - Tied hash for template tags handling

        +

        +

        +
        +

        SYNOPSIS

        +
        +    my $vars = GT::Template->vars;
        +    print $vars->{foo};
        +

        +

        +
        +

        DESCRIPTION

        +

        This module is designed to provide a simple interface to GT::Template tags from +Perl code. Prior to this module, the tags() method of GT::Template returned a +hash reference which could contain all sorts of different values - scalar +references, LVALUE references, GT::Config objects, etc. This new interface +provides a tied hash reference designed to aid in retrieving and setting values +in the same way template variables are retrieved and set from templates.

        +

        +

        +
        +

        INTERFACE

        +

        +

        +

        Accessing values

        +

        Accessing a value is simple - just access $vars->{name}. The regular +rules of escaping apply here: if the value would have been HTML-escaped in the +template, it will be escaped when you get it.

        +

        +

        +

        Setting values

        +

        Setting a value is easy - simply do: $vars->{name} = $value;. ``name'' +can be anything GT::Template recognises as a variable, so +$vars->{'name.key'} would set ->{name}->{key} (see +Advanced variables using references in the GT::Template::Tutorial manpage for more +information on complex variables).

        +

        The regular rules of escaping apply here: if escaping is turned on, a value you +set will be escaped when accessed again via $vars or in a template. If you +want to set a tag containing raw HTML, you should set a scalar reference, such +as: $vars->{name} = \$value;.

        +

        +

        +

        Keys, Exists

        +

        You can use keys %$vars to get a list of keys of the tag object, but you +should note that while $vars->{"a.b"} is valid and +exists $vars->{"a.b"} may return true, it will not be present in the +list of keys returned by keys %$vars.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::Template manpage

        +

        the GT::Template::Tutorial manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Vars.pm,v 1.8 2006/12/06 23:55:52 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI.html new file mode 100644 index 0000000..7fa6db5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI.html @@ -0,0 +1,514 @@ + + + + +GT::URI - Internet resource request broker + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::URI - Internet resource request broker

        +

        +

        +
        +

        SYNOPSIS

        +
        +  use GT::URI;
        +  my $doc = GT::URI->get( 'http://www.gossamer-threads.com' );
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::URI Makes requests and retrieves resources from internet servers.

        +

        +

        +
        +

        BASICS

        +

        +

        +

        Getting a resource, the simple way

        +

        Just want just a few items? Call GT::URI::HTTP->get and all the magic will be done for you.

        +
        +  use GT::URI;
        +  my $docs = GT::URI->get( "http://www.gossamer-threads.com/";, "http://www.google.com/";, "http://www.somethingelse.com"; );
        +

        If options need to be set, include a hashref that has the appropriate setting you'd like set

        +
        +  use GT::URI;
        +  my $conf = { max_down => 2000  };
        +  my $docs = GT::URI::HTTP->get( $conf, "http://www.gossamer-threads.com/";, "http://www.google.com/";, "http://www.somethingelse.com"; );
        +

        +

        +

        When you've got better things to do than wait

        +

        The simple method blocks when acquiring the data, meaning until all the data is downloaded, your script is frozen. GT::URI has the capability to do handle things in a non-blocking fashion, so while you wait for the documents to download, you can do something else.

        +

        A very simple example follows.

        +
        +  use GT::URI;
        +  use GT::Dumper;
        +
        +  $uri = new GT::URI();
        +
        +  # queue up the URIs wanted
        +  $uri->rack_uri( "http://www.gossamer-threads.com/";, "http://www.google.com/";, "http://www.somethingelse.com"; );
        +
        +  # loop through until there are no more requests left to finish
        +  while ( $uri->requests() ) {
        +               $docs = $uri->do_iteration();
        +
        +               # do something here
        +               print '.';
        +             }
        +
        +  # output all the data
        +  print Dumper($docs);
        +

        But this can quickly get much more complex. Since the downloads are asynchronous, the code can be changed to handle each request as it comes in.

        +
        +  use GT::URI;
        +  use GT::Dumper;
        +
        +  $uri = new GT::URI();
        +
        +  # queue up the URIs wanted
        +  $uri->rack_uri( "http://www.gossamer-threads.com/";, "http://www.google.com/";, "http://www.somethingelse.com"; );
        +
        +  # loop through until there are no more requests left to finish
        +  while ( $uri->requests() ) {
        +
        +               $uri->do_iteration();
        +
        +               # if there are any completed requests, handle them
        +               if ( my $number_completed = $uri->completed_requests() ) {
        +
        +                  print "Completed $number_completed request(s):\n";
        +                  my $completed = $uri->completed();
        +                  print Dumper( $completed );
        +
        +                  # IMPORTANT: the object caches downloaded requests, once the
        +                  # data wanted has been pulled out of the object, clear the object's 
        +                  # cache. Otherwise, the resource will appear again in the next
        +                  # $uri->completed() call
        +                  $uri->clear_completed();
        +               }
        +
        +               # do something here
        +               print '.';
        +             }
        +
        +  # output all the data
        +  print Dumper($docs);
        +

        It is possible to queue more links with the $uri->rack_uri() within the loop safely though a separate accounting system must be designed to prevent infinite loops.

        +

        +

        +

        Options to configure GT::URI

        +

        GT::URI has only a few options to control it's behaviour: There's not much it does that can be configured!

        +
        +  $opts = {
        +
        +        # maximum number of bytes to download for a single resource
        +            'max_down'    => 0,
        +
        +        # maximum number of simultaneous downloads
        +            'max_simultaneous'    => 10,
        +
        +        # configuration settings for individual protocols, look in 
        +        # any GT::URI::xxxx protocol module to find out related
        +        # configuration options
        +             'protocol_opts' => {
        +                                'protocol_name' => {
        +                                                     setting => value,
        +                                                    ...
        +                                                    },
        +                                # eg
        +                                'HTTP'    => {
        +                                            'agent_name' => 'example agent name option value'
        +                                            }
        +                                
        +                              }
        +           }
        +

        +

        +

        The main data structure GT::URI creates

        +

        The data structure that GT::URI produces to house all the resource infomation is mildly complex.

        +
        +  $docs = {
        +             'uri requested' => {
        +                                    'buffer' => 'resource data',
        +                                    'resource_attribs' => {
        +                                                               'resource_key' => 'value'
        +                                                               },
        +                                    'extra info' => ....
        +                                 }
        +           }
        +

        The 'buffer' will contain the raw http data, 'resource_attribs' will contain extra information related to the resource.

        +

        Depending on the service requested, there could be more information added. Currently no protocol requires the need for an extra key.

        +

        +

        +
        +

        METHOD LIST

        +

        Socket Handling

        +
        +  sub do_iteration()        Basic looping function that downloads resources in the background
        +  sub pending()             Returns true if data awaiting
        +

        Acquisition

        +
        +  sub completed()           Returns a hash of all the completed requests
        +  sub completed_requests()  The number of requests completed
        +  sub clear_completed()     Cleans the completed request cache
        +  sub get()                 Simple resource aquisition function
        +  sub rack_uri()            Add a URI to be downloaded
        +  sub requests()            Returns number of active requests
        +  sub vec()                 Sets file bits suitable for a select call
        +

        +

        +

        completed () : completed_requests HASHREF

        +

        Returns a datastructure with the cached completed documents.

        +

        +

        +

        completed_requests () : num_requests INTEGER

        +

        Returns the current number of completed requests in the cache.

        +

        +

        +

        clear_completed ()

        +

        Clears the completed document cache.

        +

        +

        +

        do_iteration () : completed_requests HASHREF

        +

        The major bulk of the non-blocking work is handled within this function.

        +

        +

        +

        GT::URI->get ( [ conf HASHREF, ] url STRING, url STRING, url STRING..., ) : completed_requests HASHREF

        +

        The simplest way of acquiring a number of pages. Call and it will return a the GT::URI data structure.

        +

        The configuration hashref, can be found anywhere in the list. The function will iterate through the get parameters and assume any hashref is an option parameter and any scalar an URI.

        +

        +

        +

        pending () : status BOOLEAN

        +

        Returns '1' or '0' if there is data pending to be downloaded for any of the requests

        +

        +

        +

        rack_uri ( url1 STRING, [ url2 STRING ... ] )

        +

        Takes a list of URLs and queues them for download.

        +

        +

        +

        requests ( tics INTEGER ) :

        +

        Will return the number of requests pending action in the downloading queue. Usually this would be followed up with a call to $uri->do_iteration();

        +

        +

        +

        vec ( [ bits STRING ] ) : bits STRING

        +

        Returns a bit mask that can be used in a call to select. If you want to use an already existing bit mask, pass it into the function and the appropriate bits from requets will be additionally set.

        +

        +

        +
        +

        BUILDING PROTOCOL HANDLERS

        +

        forthcoming

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: URI.pm,v 1.24 2002/04/07 03:35:35 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTP.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTP.html new file mode 100644 index 0000000..aa8caad --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTP.html @@ -0,0 +1,672 @@ + + + + +GT::URI::HTTP - HTTP request broker. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::URI::HTTP - HTTP request broker.

        +

        +

        +
        +

        SYNOPSIS

        +
        +  use GT::URI::HTTP;
        +
        +  print GT::URI::HTTP->get( "http://www.gossamer-threads.com"; );
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::URI::HTTP makes requests and retrieves resources from http servers (not +limited to text). Can be used stand-alone or through GT::URI

        +

        +

        +
        +

        Method List

        +

        Socket Handling

        +
        +  sub pending()            Returns true if data awaiting
        +  sub EOF()                Returns open/closed status of socket
        +  sub gulp_read()          Alias to do_iteration
        +  sub do_iteration()       Basic looping function that downloads resources in the background
        +

        Acquisition

        +
        +  sub fetch()              Tell the object which URL to acquire
        +  sub method()             The method of acquisition
        +  sub load_parameter()     Add a item for CGI parameters
        +  sub delete_parameter()   Delete a CGI parameter
        +  sub resource_attrib()    Headers related to resource and server
        +  sub get()                Simple resource aquisition function
        +

        Support Methods (must be imported)

        +
        +  sub parse_url()          Decomposes a URL into constituent parts
        +  sub deparse_url()        Takes those parts and builds an URL  
        +  sub build_path()         Takes a list of directories and builds a path
        +  sub build_parameters()   Takes a hash of parameter->values and builds a CGI request string
        +

        +

        +
        +

        Basics

        +

        +

        +

        Getting a resource, the simple way

        +

        Just want a single item? Call GT::URI::HTTP->get and all the magic will be done +for you.

        +
        +  use GT::URI::HTTP;
        +  my $buf = GT::URI::HTTP->get( "http://www.gossamer-threads.com/"; );
        +

        Get based requests are permissable as well:

        +
        +  use GT::URI::HTTP;
        +  my $buf = GT::URI::HTTP->get( "http://search.yahoo.com/bin/search?p=gossamer+threads"; );
        +

        If extra options need to be set, simply append the options to the parameter +list, like follows.

        +
        +  use GT::URI::HTTP;
        +  my $buf = GT::URI::HTTP->get( "http://search.yahoo.com/bin/search?p=gossamer+threads";, { request_method => 'POST'  } );
        +

        +

        +

        When just the document is not enough

        +

        If a new GT::URI::HTTP object is instantiated, much more control is available, +including facilities for non-blocking downloading of pages.

        +

        To create a GT::URI::HTTP object, call new with all the options required:

        +
        +  use GT::URI::HTTP;
        +
        +  my $http = new GT::URI::HTTP(
        +
        +                    # URL to acquire (optional)
        +                        'URL'               => '',
        +
        +                    # Can also be set to POST/GET/HEAD (optional)
        +                        'request_method'    => 'GET',
        +
        +                    # a hash of keys pointing to an arrayref of values to be sent to the server
        +                    # {
        +                    #    'key' => [ 'value1', 'value2'... ],
        +                    # }
        +                    # (optional)
        +                        'parameters'        => {},
        +
        +                    # Name portion of the User-Agent: string the server acquires (optional)
        +                        'agent_name'        => 'Mozilla/4.73 [en]',
        +
        +                    # Host-from portion of the User-Agent: string the server acquires (optional)
        +                        'agent_host'        => 'X11; I; Linux 2.2.15-4mdk i586',
        +
        +                    # To prevent downloading of 80Tb files, but if you still wanted to, set this to 0 (optional)
        +                        'max_down'          => 200000
        +
        +                    );
        +

        If URL has been specified in the options, for interactions with a CGI, you can +set extra parameters with $http->load_parameter(). Finally, loop on +$http->do_iteration() until the value is defined. To replicate the ``simple get'' +example:

        +
        +  use GT::URI::HTTP;
        +  $|++;
        +
        +  my $http = new GT::URI::HTTP(
        +
        +                              URL        => 'http://search.yahoo.com/bin/search',
        +
        +                              # can also use the following:
        +                              parameters => {
        +                                              'p' => [ 'gossamer threads' ]
        +                                            }
        +
        +                              );
        +
        +  my $doc;
        +  while ( not defined( $doc = $http->do_iteration() ) ) {
        +          # do something here while waiting for the resource to arrive 
        +          print "." 
        +          }
        +
        +  print $doc, "\n\n";
        +

        Beyond the resource, the http server often supplies extra information in a +header. To access this information, use $http->resource_attrib().

        +

        Appending this code to the previous example, a list of all the associated server +headers can be seen:

        +
        +  my $attribs = $http->resource_attrib();
        +  foreach my $key ( sort keys %{$attribs} ) {
        +    print "$key => $attribs->{$key}\n";
        +  }
        +

        +

        +

        Support Methods

        +

        In addition to the basic fetching abilities, since the module must parse HTTP +URLs, the methods used to do so have been made public.

        +

        These methods decompose URLs into datastructures that make URLs easily studied +or modified and then reconstructed.

        +

        However, these routines have not been polished for useability so beware! The +following is a very basic example:

        +
        +  use GT::URI::HTTP qw/ parse_url deparse_url build_path build_parameters /;
        +
        +  # fragment the URL
        +  my ( $host, $port, $dirs, $file, $params ) = parse_url( 'http://www.gossamer-threads.com/perl/forum/showflat.pl?Cat=&Board=GosDisc&Number=113355&page=0&view=' );
        +
        +  print "Parsed Data:\n\n";
        +  print "Host: $host\n";
        +  print "Port: $port\n";
        +  print "Dirs:\n";
        +  foreach my $dir ( @{$dirs} ) {
        +      print "  $dir/\n";
        +  }
        +  print "Resource Filename: $file\n";
        +  print "Params:\n";
        +  foreach my $key ( sort keys %{$params} ) {
        +    print "  $key: ";
        +    my $values    = ( $params->{$key} || {} );
        +    foreach my $value ( sort @{$values} ) {
        +      print "'", quotemeta($value), "' ";
        +    }
        +    print "\n";
        +  }
        +
        +  # put the data back together again
        +  my $url = deparse_url( $host, $port, $dirs, $file, $params );
        +  print "\nDeparsed Data:\n\n";
        +  print "URL: http://$url\n";
        +

        +

        +
        +

        Methods List

        +

        +

        +

        build_path ( dir ARRAYREF, [ page STRING ] ) : STRING

        +

        Takes an array ref of directory names and an optional filename and returns a +filepath.

        +
        +  use GT::URI::HTTP qw/ build_path /;
        +  print build_path( [ 'topdir', 'middir', 'bottomdir' ], 'file.html' );
        +

        This function must be imported.

        +

        +

        +

        build_parameters ( parameter HASHREF ) : STRING

        +

        Builds a CGI request string from list of keys and values. The function has the +ability to handle keys with more than one parameter, simply use an arrayref with +multiple values.

        +
        +  use GT::URI::HTTP qw/ build_parameters /;
        +  my $params = {
        +                   'simplekey' => 'value'
        +                   'onekey' => [ 'one value' ],
        +                   'anotherkey' => [ 'another value', 'and yet anotherone!' ],
        +                };
        +  print build_parameters($params);
        +

        This function must be imported.

        +

        +

        +

        delete_parameter ( keys ARRAYREF/ARRAY )

        +

        When loading the object with parameters before a request, it is possible to +delete an entire set of keys and values.

        +

        +

        +

        deparse_url ( host STRING, [ port STRING, [ dirs ARRAYREF, [ file STRING, [ params HASH ] ] ] ] ) : STRING

        +

        This builds an entire URL from basic parameters.

        +

        For an example of this function, see the example in ``Support Methods''.

        +

        This function must be imported.

        +

        +

        +

        do_iteration ( tics INTEGER ) : STRING

        +

        The basic iteration function. This function will return undef until the resource +is received which, upon receipt will return the resource data.

        +

        The function can return an empty string, so it is important to checked +defined'ness. If the return is an empty string, check the ERROR_CODE in +resource_attrib to find out if the script simply can't connect to the host or +the resource is empty.

        +

        +

        +

        EOF () : BOOLEAN

        +

        Returns '1' or '0' depending if the object has stopped receiving/sending data to +the remote server.

        +

        +

        +

        fetch ( url STRING, [ parameters HASHREF ] )

        +

        Tells the server the URL to retreive the resource of. If CGI parameters are +required pass in a hash of keys and values.

        +

        +

        +

        GT::URI::HTTP->get ( url, [ options HASH/HASHREF ] ) : RESOURCE_DATA

        +

        Simplest resource aquision method. Give it the URL and any options and the +function will return after the resource has been downloaded.

        +

        +

        +

        gulp_read ( tic INTEGER ) : RESOURCE_DATA

        +

        This is just an alias to the function do_iteration. This method is used by +GT::URI in its mass resource aquisition runs.

        +

        Unless you feel like being different, you shouldn't need to use this.

        +

        +

        +

        load_parameter ( params HASH/HASHREF ) : HASHREF

        +

        Takes a list of keys and values and loads the values into the list of CGI +parameters to be sent to the remote server.

        +

        +

        +

        method ( method STRING ) : STRING

        +

        Sets the acquisition method for the resource. Currently, GET/POST/HEAD are +supported.

        +

        If no parameters are supplied the function simply returns the current +acquisition method.

        +

        +

        +

        parse_url ( url STRING ) : host STRING, port INTEGER, dirs ARRAYREF, +file STRING, params HASHREF

        +

        Takes an URL and decomposes it into easily manipulated datastructures. The +output can be fed back into deparse_url to reconstruct an URL.

        +

        This function must be imported.

        +

        +

        +

        pending ( tics INTEGER ) : BOOLEAN

        +

        If there is data available to be downloaded, this function returns '1', +otherwise '0'. This is another function used by GT::URI in it's mass downloads +and unlikely to be of any use to anyone using this module directly. This +function exists because it is lighter than do_iteration which can be quite a +load as opposed to this if there were 100 racked downloads, all being polled +every tenth of a second!

        +

        +

        +

        resource_attrib ( [ key STRING ] ) STRING or HASHREF

        +

        If a key is requested, function will return the value associated with the +resource attribute. If not, the function will return a hashref keyed by server +parameter to its corresponding value.

        +

        All the server keys have been converted into lower-case. This prevents conflict +with two very important keys, ERROR_CODE, and ERROR_MESSAGE, which carry the +HTTP error code and message associated with the aquisition of this page.

        +

        +

        +
        +

        EXAMPLES

        +

        +

        +

        HTTP get example

        +
        +  #!/usr/bin/perl
        +
        +  use GT::URI::HTTP;
        +
        +  if ( not @ARGV ) {
        +    print qq!
        +    SYNOPSIS
        +
        +      $0 url [-f/-h] [ cgi_parameter1=value1 cgi_parameter2=value2 ... ]
        +
        +    basic HTTP requestor
        +
        +    OPTIONS
        +
        +    -f : full information; headers and resource. Usually only a dump of the resource is provided.
        +    -h : just the headers\n\n!;
        +    exit;
        +  }
        +
        +  # parse out the command line
        +  # first argument, URL
        +  $url  = shift @ARGV;
        +
        +  # next arguments, parameters
        +  foreach my $item ( @ARGV ) {
        +
        +  # ... check for special requests
        +    if ( $item =~ /^-([fd])$/ ) {
        +      $mode = $1;
        +    }
        +
        +  # ... is not a special request, but probably a parameter
        +    ( $key, $value ) = ( $item =~ /([^=]+)=(.*)/ );
        +    $key ||= $item;
        +    push @{$parameters->{$key}}, $value;
        +  }
        +
        +  # setup and send the request
        +  $http = new GT::URI::HTTP(
        +
        +                            # if we're only looking to use the head
        +                            request_method => ( $mode eq 'h' ? 'HEAD' : 'GET' )
        +
        +                            );
        +  $http->fetch( $url, $parameters );
        +
        +  # get the resource
        +  while ( not defined ( $doc = $http->do_iteration(-1) ) ) {}
        +
        +  # and print out the headers if wanted
        +  if ( $mode ) {
        +    $headers = $http->resource_attrib();
        +    foreach $key ( sort keys %{$headers || {}} ) {
        +      print "$key: $headers->{$key}\n";
        +    }
        +    print "\n";
        +  }
        +
        +  # and output the resource...
        +  print $doc;
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: HTTP.pm,v 1.30 2002/06/27 18:36:02 aki Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTPS.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTPS.html new file mode 100644 index 0000000..22b4399 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/URI/HTTPS.html @@ -0,0 +1,634 @@ + + + + +GT::URI::HTTPS - HTTPS request broker. Can be used stand-alone or through GT::URI + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::URI::HTTPS - HTTPS request broker. Can be used stand-alone or through GT::URI

        +

        +

        +
        +

        SYNOPSIS

        +
        +  use GT::URI::HTTPS;
        +
        +  print GT::URI::HTTPS->get( "http://www.gossamer-threads.com"; );
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::URI::HTTPS makes requests and retrieves resources from http servers (not limited to text).

        +

        +

        +
        +

        Method List

        +

        Socket Handling

        +
        +  sub pending()            Returns true if data awaiting
        +  sub EOF()                Returns open/closed status of socket
        +  sub gulp_read()          Alias to do_iteration
        +  sub do_iteration()       Basic looping function that downloads resources in the background
        +

        Acquisition

        +
        +  sub fetch()              Tell the object which URL to acquire
        +  sub method()             The method of acquisition
        +  sub load_parameter()     Add a item for CGI parameters
        +  sub delete_parameter()   Delete a CGI parameter
        +  sub resource_attrib()    Headers related to resource and server
        +  sub get()                Simple resource aquisition function
        +

        Support Methods (must be imported)

        +
        +  sub parse_url()          Decomposes a URL into constituent parts
        +  sub deparse_url()        Takes those parts and builds an URL  
        +  sub build_path()         Takes a list of directories and builds a path
        +  sub build_parameters()   Takes a hash of parameter->values and builds a CGI request string
        +

        +

        +
        +

        Basics

        +

        +

        +

        Getting a resource, the simple way

        +

        Just want a single item? Call GT::URI::HTTPS->get and all the magic will be done for you.

        +
        +  use GT::URI::HTTPS;
        +  my $buf = GT::URI::HTTPS->get( "http://www.gossamer-threads.com/"; );
        +

        Get based requests are permissable as well:

        +
        +  use GT::URI::HTTPS;
        +  my $buf = GT::URI::HTTPS->get( "http://search.yahoo.com/bin/search?p=gossamer+threads"; );
        +

        If extra options need to be set, simply append the options to the parameter list, like follows.

        +
        +  use GT::URI::HTTPS;
        +  my $buf = GT::URI::HTTPS->get( "http://search.yahoo.com/bin/search?p=gossamer+threads";, { request_method => 'POST'  } );
        +

        +

        +

        When just the document is not enough

        +

        If a new GT::URI::HTTPS object is instantiated, much more control is available, including facilities for non-blocking downloading of pages.

        +

        To create a GT::URI::HTTPS object, call new with all the options required:

        +
        +  use GT::URI::HTTPS;
        +
        +  my $http = new GT::URI::HTTPS(
        +
        +                    # URL to acquire (optional)
        +                        'URL'               => '',
        +
        +                    # Can also be set to POST/GET/HEAD (optional)
        +                        'request_method'    => 'GET',
        +
        +                    # a hash of keys pointing to an arrayref of values to be sent to the server
        +                    # {
        +                    #    'key' => [ 'value1', 'value2'... ],
        +                    # }
        +                    # (optional)
        +                        'parameters'        => {},
        +
        +                    # Name portion of the User-Agent: string the server acquires (optional)
        +                        'agent_name'        => 'Mozilla/4.73 [en]',
        +
        +                    # Host-from portion of the User-Agent: string the server acquires (optional)
        +                        'agent_host'        => 'X11; I; Linux 2.2.15-4mdk i586',
        +
        +                    # To prevent downloading of 80Tb files, but if you still wanted to, set this to 0 (optional)
        +                        'max_down'          => 200000
        +
        +                    );
        +

        If URL has been specified in the options, for interactions with a CGI, you can set extra parameters with $http->load_parameter(). Finally, loop on $http->do_iteration() until the value is defined. To replicate the ``simple get'' example:

        +
        +  use GT::URI::HTTPS;
        +  $|++;
        +
        +  my $http = new GT::URI::HTTPS(
        +
        +                              URL        => 'http://search.yahoo.com/bin/search',
        +
        +                              # can also use the following:
        +                              parameters => {
        +                                              'p' => [ 'gossamer threads' ]
        +                                            }
        +
        +                              );
        +
        +  my $doc;
        +  while ( not defined( $doc = $http->do_iteration() ) ) {
        +          # do something here while waiting for the resource to arrive 
        +          print "." 
        +          }
        +
        +  print $doc, "\n\n";
        +

        Beyond the resource, the http server often supplies extra information in a header. To access this information, use $http->resource_attrib().

        +

        Appending this code to the previous example, a list of all the associated server headers can be seen:

        +
        +  my $attribs = $http->resource_attrib();
        +  foreach my $key ( sort keys %{$attribs} ) {
        +    print "$key => $attribs->{$key}\n";
        +  }
        +

        +

        +

        Support Methods

        +

        In addition to the basic fetching abilities, since the module must parse HTTPS URLs, the methods used to do so have been made public.

        +

        These methods decompose URLs into datastructures that make URLs easily studied or modified and then reconstructed.

        +

        However, these routines have not been polished for useability so beware! The following is a very basic example:

        +
        +  use GT::URI::HTTPS qw/ parse_url deparse_url build_path build_parameters /;
        +
        +  # fragment the URL
        +  my ( $host, $port, $dirs, $file, $params ) = parse_url( 'http://www.gossamer-threads.com/perl/forum/showflat.pl?Cat=&Board=GosDisc&Number=113355&page=0&view=' );
        +
        +  print "Parsed Data:\n\n";
        +  print "Host: $host\n";
        +  print "Port: $port\n";
        +  print "Dirs:\n";
        +  foreach my $dir ( @{$dirs} ) {
        +      print "  $dir/\n";
        +  }
        +  print "Resource Filename: $file\n";
        +  print "Params:\n";
        +  foreach my $key ( sort keys %{$params} ) {
        +    print "  $key: ";
        +    my $values    = ( $params->{$key} || {} );
        +    foreach my $value ( sort @{$values} ) {
        +      print "'", quotemeta($value), "' ";
        +    }
        +    print "\n";
        +  }
        +
        +  # put the data back together again
        +  my $url = deparse_url( $host, $port, $dirs, $file, $params );
        +  print "\nDeparsed Data:\n\n";
        +  print "URL: http://$url\n";
        +

        +

        +
        +

        Methods List

        +

        +

        +

        build_path ( dir ARRAYREF, [ page STRING ] ) : STRING

        +

        Takes an array ref of directory names and an optional filename and returns a filepath.

        +
        +  use GT::URI::HTTPS qw/ build_path /;
        +  print build_path( [ 'topdir', 'middir', 'bottomdir' ], 'file.html' );
        +

        This function must be imported.

        +

        +

        +

        build_parameters ( parameter HASHREF ) : STRING

        +

        Builds a CGI request string from list of keys and values. The function has the ability to handle keys with more than one parameter, simply use an arrayref with multiple values.

        +
        +  use GT::URI::HTTPS qw/ build_parameters /;
        +  my $params = {
        +                   'simplekey' => 'value'
        +                   'onekey' => [ 'one value' ],
        +                   'anotherkey' => [ 'another value', 'and yet anotherone!' ],
        +                };
        +  print build_parameters($params);
        +

        This function must be imported.

        +

        +

        +

        delete_parameter ( keys ARRAYREF/ARRAY )

        +

        When loading the object with parameters before a request, it is possible to delete an entire set of keys and values.

        +

        +

        +

        deparse_url ( host STRING, [ port STRING, [ dirs ARRAYREF, [ file STRING, [ params HASH ] ] ] ] ) : STRING

        +

        This builds an entire URL from basic parameters.

        +

        For an example of this function, see the example in ``Support Methods''.

        +

        This function must be imported.

        +

        +

        +

        do_iteration ( tics INTEGER ) : STRING

        +

        The basic iteration function. This function will return undef until the resource is received which, upon receipt will return the resource data.

        +

        The function can return an empty string, so it is important to checked defined'ness. If the return is an empty string, check the ERROR_CODE in resource_attrib to find out if the script simply can't connect to the host or the resource is empty.

        +

        +

        +

        EOF () : BOOLEAN

        +

        Returns '1' or '0' depending if the object has stopped receiving/sending data to the remote server.

        +

        +

        +

        fetch ( url STRING, [ parameters HASHREF ] )

        +

        Tells the server the URL to retreive the resource of. If CGI parameters are required pass in a hash of keys and values.

        +

        +

        +

        GT::URI::HTTPS->get ( url, [ options HASH/HASHREF ] ) : RESOURCE_DATA

        +

        Simplest resource aquision method. Give it the URL and any options and the function will return after the resource has been downloaded.

        +

        +

        +

        gulp_read ( tic INTEGER ) : RESOURCE_DATA

        +

        This is just an alias to the function do_iteration. This method is used by GT::URI in its mass resource aquisition runs.

        +

        Unless you feel like being different, you shouldn't need to use this.

        +

        +

        +

        load_parameter ( params HASH/HASHREF ) : HASHREF

        +

        Takes a list of keys and values and loads the values into the list of CGI parameters to be sent to the remote server.

        +

        +

        +

        method ( method STRING ) : STRING

        +

        Sets the acquisition method for the resource. Currently, GET/POST/HEAD are supported.

        +

        If no parameters are supplied the function simply returns the current acquisition method.

        +

        +

        +

        parse_url ( url STRING ) : host STRING, port INTEGER, dirs ARRAYREF, file STRING, params HASHREF

        +

        Takes an URL and decomposes it into easily manipulated datastructures. The output can be fed back into deparse_url to reconstruct an URL.

        +

        This function must be imported.

        +

        +

        +

        pending ( tics INTEGER ) : BOOLEAN

        +

        If there is data available to be downloaded, this function returns '1', otherwise '0'. This is another function used by GT::URI in it's mass downloads and unlikely to be of any use to anyone using this module directly. This function exists because it is lighter than do_iteration which can be quite a load as opposed to this if there were 100 racked downloads, all being polled every tenth of a second!

        +

        +

        +

        resource_attrib ( [ key STRING ] ) STRING or HASHREF

        +

        If a key is requested, function will return the value associated with the resource attribute. If not, the function will return a hashref keyed by server parameter to its corresponding value.

        +

        All the server keys have been converted into lower-case. This prevents conflict with two very important keys, ERROR_CODE, and ERROR_MESSAGE, which carry the HTTPS error code and message associated with the aquisition of this page.

        +

        +

        +
        +

        EXAMPLES

        +

        +

        +

        HTTPS get example

        +
        +  #!/usr/bin/perl
        +
        +  use GT::URI::HTTPS;
        +
        +  if ( not @ARGV ) {
        +    print qq!
        +    SYNOPSIS
        +
        +      $0 url [-f/-h] [ cgi_parameter1=value1 cgi_parameter2=value2 ... ]
        +
        +    basic HTTPS requestor
        +
        +    OPTIONS
        +
        +    -f : full information; headers and resource. Usually only a dump of the resource is provided.
        +    -h : just the headers\n\n!;
        +    exit;
        +  }
        +
        +  # parse out the command line
        +  # first argument, URL
        +  $url  = shift @ARGV;
        +
        +  # next arguments, parameters
        +  foreach my $item ( @ARGV ) {
        +
        +  # ... check for special requests
        +    if ( $item =~ /^-([fd])$/ ) {
        +      $mode = $1;
        +    }
        +
        +  # ... is not a special request, but probably a parameter
        +    ( $key, $value ) = ( $item =~ /([^=]+)=(.*)/ );
        +    $key ||= $item;
        +    push @{$parameters->{$key}}, $value;
        +  }
        +
        +  # setup and send the request
        +  $http = new GT::URI::HTTPS(
        +
        +                            # if we're only looking to use the head
        +                            request_method => ( $mode eq 'h' ? 'HEAD' : 'GET' )
        +
        +                            );
        +  $http->fetch( $url, $parameters );
        +
        +  # get the resource
        +  while ( not defined ( $doc = $http->do_iteration(-1) ) ) {}
        +
        +  # and print out the headers if wanted
        +  if ( $mode ) {
        +    $headers = $http->resource_attrib();
        +    foreach $key ( sort keys %{$headers || {}} ) {
        +      print "$key: $headers->{$key}\n";
        +    }
        +    print "\n";
        +  }
        +
        +  # and output the resource...
        +  print $doc;
        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: HTTPS.pm,v 1.10 2004/08/23 20:07:44 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW.html new file mode 100644 index 0000000..eb7f0ea --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW.html @@ -0,0 +1,726 @@ + + + + +GT::WWW - Multi-protocol retrieving and posting, related in functionality to +LWP. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::WWW - Multi-protocol retrieving and posting, related in functionality to +LWP.

        +

        +

        +
        +

        DESCRIPTION

        +

        GT::WWW is designed to provide a common interface for multiple protocols (as of +this writing, only HTTP and HTTPS, however others are planned) and handles +HEAD, GET, and POST requests. For non-HTTP-based protocols, what, exactly, a +``HEAD'', ``GET'', or ``POST'' request is depends on the module in question. For +example, with FTP ``GET'' might download a file, while ``POST'' might upload one to +the server, and ``HEAD'' might return just the size of the file.

        +

        The modules under GT::WWW should not be used directly; this module should be +used instead. The documentation here describes the options common to all +protocols - however you should check the POD of the protocol subclasses +(GT::WWW::http, GT::WWW::https, etc.) to see any extra options or methods that +those modules provide.

        +

        +

        +
        +

        SYNOPSIS

        +

        Quick way:

        +
        +    use GT::WWW;
        +    my $www = GT::WWW->get("http://server.com/page";);
        +    ...     = GT::WWW->post("http://server.com/page";);
        +    ...     = GT::WWW->head("http://server.com/page";);
        +    ...     = GT::WWW->...("http://user:pass@server.com/page";);
        +    ...     = GT::WWW->...("https://server.com/page");
        +
        +    # This query string will be parsed and passed as POST input:
        +    ...     = GT::WWW->post("http://server.com/page?foo=bar;bar=foo";);
        +

        Longer, but more capable way:

        +
        +    use GT::WWW;
        +    my $request = GT::WWW->new();
        +
        +    $request->protocol("http");
        +    $request->host("server.com");
        +    $request->port(8080);
        +    $request->path("/path/foo.cgi");
        +    $request->username("user");
        +    $request->password("pass");
        +    $request->parameters(foo => "bar", bar => "foo");
        +

        equivelant to the above, using ->url():

        +
        +    $request->url("http://user:pass@server.com:8080/path/foo.cgi?foo=bar;bar=foo";);
        +

        Now call $request->get(), $request->post(), or $request->head().

        +

        Very quick way to print a page:

        +
        +    perl -MGT::WWW=get -e 'print get("http://server.com/page?foo=bar&bar=foo";)'
        +

        +

        +
        +

        METHODS

        +

        Note that all methods that set values (such as host(), port(), etc.) also +return the value when called without any argument.

        +

        +

        +

        new

        +

        Call new() to get a new GT::WWW object. You can call it without arguments to +get a generic GT::WWW object, or use arguments as described below.

        +
        +
        URL + +
        +

        You can call new with a single scalar argument - a URL to be parsed. The URL is +of the same format as taken by the url() method.

        +
        + +
        HASH + +
        +

        You can alternatively call new() with a hash (or hash reference) of options. +Each of the methods described below can be passed in to new in the form of +key => value pairs - the methods will be called with the values +specified automatically.

        +
        + +
        +

        +

        +

        head

        +

        +

        +

        get

        +

        +

        +

        post

        +

        These are the methods used to tell the module to actually connect to the server +and download the requested page.

        +

        When used as GT::WWW class methods or function calls (but NOT as methods on +GT::WWW objects or sub-objects), they take a single URL as an argument. This +call creates an internal GT::WWW object, turns on +fatal_errors(1), passes the URL to url(), then +calls the appropriate get(), head(), or post() method of the resulting +protocol-specific object.

        +

        Note, however, that once you have specified a protocol (either via +protocol(), or as part of a url passed to url()) +your object ceases to be a GT::WWW object and becomes a protocol-specific +GT::WWW subclass. All subclasses provide their own versions of these methods.

        +

        The subclassed methods are not described here because they may not be supported +for all protocols, and their return value(s) may differ from one protocol to +the next. For more details, see the modules listed in the +SEE ALSO section.

        +

        Generally, get() and post() return an overloaded object that can be used as a +string to get the content (i.e. for printing), but see the notes in the CAVEATS +section of the GT::WWW::http::Response manpage for anything more complicated than +concatenation or printing.

        +

        +

        +

        url

        +

        Takes a URL as argument. The URL is parsed into several fields: protocol, +username, password, host, port, path, and query_string, then +each of those properties are set for the current object. Also note that +calling url() on an existing object resets the host, port, username, password, +and all parameters.

        +

        Interally, this method calls parse_url().

        +

        +

        +

        parse_url

        +

        Takes a URI, and returns the following 7 element list:

        +
        +    #    0          1          2        3      4      5          6
        +    ($protocol, $username, $password, $host, $port, $path, $query_string) =
        +        GT::WWW->parse_url($url);
        +

        URL's require, at a minimum, protocol and host, in URI form:

        +
        +    PROTOCOL://HOST
        +

        The URL can extend up to:

        +
        +    PROTOCOL://USERNAME:PASSWORD@HOST:PORT/PATH?QUERY_STRING
        +

        Only protocols known to GT::WWW are acceptable. To check if a URL is valid, +check $protocol.

        +

        This method can be called as a class or object method, but not as a function. +If called as an object method, the strict option as currently set for the +object will be used; as a class method or function, an optional second +parameter can be passed in - if true, strict query string parsing mode will be +enabled.

        +

        +

        +

        protocol

        +

        Takes a protocol, such as 'http', 'https', 'ftp', etc. Note that when you call +protocol, you object ceases being a GT::WWW object, by becoming a GT::WWW subclass +(such as GT::WWW::http, GT::WWW::https, etc.). Before trying an unknown protocol, +you should generally call the protocol_supported method - calling +protocol(...) with an unsupported protocol will result in a fatal error.

        +

        +

        +

        protocol_supported

        +

        This method takes a protocol, such as 'http', 'https', 'ftp', etc. In order to +make sure the protocol is supported, this checks to see that it is an +internally supported protocol, and also tries to load the module to make sure +that the module can be loaded.

        +

        +

        +

        valid_host

        +

        Returns true in scalar context if the host appears valid, or the host and port +in list context if the host is valid. Note that no check is performed to see +whether or not the host resolves or is reachable - this simply verifies that +the host is at least valid enough to warrant a lookup.

        +

        +

        +

        host

        +

        Sets the host, and optionally the port (assuming the argument is of the form: +'hostname:port'). Returns a fatal error if the host is not valid. Note that +setting the host will reset the port to the protocol's default value, so +this method must be called before port().

        +

        +

        +

        port

        +

        Sets the port for the connection. This can be a name, such as ``smtp'', or a +numeric value. Note that the port value will be reset when the host() +method is called, so setting a port must happen after setting the host.

        +

        +

        +

        reset_port

        +

        Resets the port so that the next request will use the default port.

        +

        +

        +

        username

        +

        Sets or retrieves the login username.

        +

        +

        +

        reset_username

        +

        Removes the login username.

        +

        +

        +

        password

        +

        Sets the login password.

        +

        +

        +

        reset_password

        +

        Removes the login password.

        +

        +

        +

        connection_timeout

        +

        Specifies a timeout for connections, in seconds. By default, a value of 10 is +used. If you specify a false value here, the connection time out will be +system dependent; typically this is from one to several minutes. Note, +however, that the timeout is not supported on Windows systems and so should not +be depended on in code that runs on Windows systems.

        +

        +

        +

        path

        +

        Sets the path for the request. Any HTTP escapes (e.g. %20) are automatically +converted to the actual value (e.g. `` ''). If required, the path will be +automatically re-escaped before being sent to the server.

        +

        +

        +

        parameters

        +

        Takes a list (not a hash, since duplicate keys are permitted) of key => value +pairs. Optionally takes an extra argument - if true, the parameters are added, +not replaced - if omitted (or false), any existing parameters are deleted.

        +

        To specify a valueless parameter without a value, such as b in this example +query string:

        +
        +    a=1&b&c=3
        +

        Pass undef as b's value. Passing ``'' as the value will result in:

        +
        +    a=1&b=&c=3
        +

        For example, to set to two query strings above would require the following two +sets of arguments, respectively:

        +
        +    $www->parameters(a => 1, b => undef, c => 3);
        +
        +    $www->parameters(a => 1, b => "", c => 3);
        +

        To then add a ``d=4'' parameter to either one, you would call:

        +
        +    $www->parameters(d => 4, 1);
        +

        Omitting the extra ``1'' would cause you to erase the previously set parameters.

        +

        Values specified should not be URL encoded.

        +

        If called without arguments, the list of key/value pairs is returned.

        +

        +

        +

        reset_parameters

        +

        Resets the parameters. You want to make sure you do this between each request +on the same object, unless using url(), which calls this for you.

        +

        +

        +

        query_string

        +

        This function serves the same purpose as parameters(), except +that it takes a query string as input instead of a list. Like parameters(), +the default behaviour is to replace any existing parameters unless a second, +true argument is provided.

        +

        Note that if you already have your parameters in some sort of list, it is +preferable to pass them to parameters() than to join them into a query +string and pass them into this function, because this function just splits them +back up into a list again.

        +

        You can also provide a query string (along with a host, path, and possibly +other data) using the url() method.

        +

        If called without arguments, the current parameters will be joined into a valid +query string and returned.

        +

        +

        +

        strict

        +

        This function is used to tell the GT::WWW object to allow/disallow +standard-violating responses. This has a global effect of allowing query +strings to contain _any_ characters except for ``\r'', ``\n'', and ``#'' - normally, +characters such as /, ?, and various extended characters much be escaped into +%XX format. The strict option may have other protocol-specific effects, +which will be indicated in each protocol's documentation.

        +

        The option defaults to non-strict.

        +

        +

        +

        post_data

        +

        This function allows you to pass in raw data to be posted. The data will not be +encoded. If you pass in a code reference, the data will be posted in chunks.

        +

        +

        +

        agent

        +

        Used to set or retrieve the User-Agent string that will be sent to the server. +If the agent string you pass starts or ends with whitespace or a comma, the +default agent will be added at the beginning of end of the User-Agent string, +respectively. This value is only meaningful to protocols supporting something +similar to the HTTP User-Agent.

        +

        +

        +

        default_agent

        +

        Returns the default user agent string. This will be automatically used if no +agent has been set, or if an agent ending with whitespace is specified. This +value is dependent on the protocol being used, but is typically something like +``GT::WWW::http/1.23''. This method is read-only.

        +

        +

        +

        chunk

        +

        +

        +

        chunk_size

        +

        chunk and chunk_size are used to perform a large download in chunks. The +chunk() method takes a code reference that will be called when a chunk of +data has been retrieved from the server, or a value of undef to clear any +currently set chunk code. chunk_size() takes a integer containing the +number bytes that you wish to retrieve at a time from the server; the chunk +code reference will be called with a scalar reference containing up to +chunk_size bytes.

        +

        Note that when using chunked downloading, the data will not be available using +the normal content retrieval interface.

        +

        Also note that, as of 1.024, the chunk code reference only applies to the next +get() or post() request - after each get() or post() request, the chunk_code is +cleared (in order to avoid self-references and possible memory leaks).

        +

        +

        +

        cancel

        +

        +

        +

        cancelled

        +

        The cancel method can be used in conjunction with the chunk +option to abort a download in progress. The chunk code will not be called +again, and the server connection will be closed. This should be used sparingly +and with care. cancelled simply return a true/false value indicating +whether the operation has been cancelled. This value is reset at the beginning +of each operation.

        +

        Note that cancelling an operation is never performed automatically, and only +happens - if ever - in the chunk code reference, so checking the +cancellation status is rarely needed.

        +

        +

        +

        debug_level

        +

        This is used to set or retrieve the debug level. +0 = no debugging +1 = debugging related to current operation +2 = adds operation details to debugging level 1 +3 = adds data debugging (very large!) to debugging level 2

        +

        When passed as part of a hash to new(), the key for this option can be specified +as debug instead of debug_level.

        +

        +

        +

        error

        +

        This method will return a string containing an error that has occurred. Note +that an error may be generated even for methods that _seem_ to be correct - for +example, if a server unexpectedly closes the connection before properly +finishing the transfer, a successful return will result since the transfer was +partially successful, but an error message will still be set.

        +

        +

        +

        fatal_errors

        +

        This method will alter the current object's error handling behaviour such that +any errors that occur will be propogated to fatal errors. It is enabled +automatically when using the quick (i.e. objectless) forms of get(), +head(), and post() methods which have no associated object on which +->error can be called.

        +

        +

        +

        file

        +

        This method is used to create a parameter for uploading a file. It takes +either one or two arguments:

        +

        2 argument form: +First argument is a remote filename, second argument is either a local +filename, or a GLOB reference to an open filehandle.

        +

        1 argument form: +Argument is a filename to read.

        +

        Example usage:

        +
        +    my $file = $www->file("foo.txt");
        +    $www->parameters(foobar => $file, 1);
        +    my $response = $www->post();
        +

        This will upload the file from disk named ``foo.txt'', using a form parameter +named ``foobar''. This is similar to uploading a file named ``foo.txt'' via the +following HTML element:

        +
        +    <input type="file" name="foobar">
        +

        The two argument form with two filenames is used to lie to the server about the +actual name of the file. Using a filehandle as the second argument is for use +when a filename is not available - such as an opened socket, or a file that has +been opened elsewhere in the code.

        +

        Examples:

        +
        +    my $file = $www->file("foo.txt", "bar.txt");
        +    my $file2 = $www->file("foo2.txt", \*FH);
        +    $www->parameters(foobar => $file, foobar2 => $file2, 1);
        +    my $response = $www->post();
        +

        This will upload two files - a file named foo.txt (which is actually read +from the bar.txt file) specified as form parameter foobar, and a second +file, specified as parameter foobar2, whose content is read from the +filehandle FH.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::WWW::http manpage +the GT::WWW::https manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: WWW.pm,v 1.29 2009/04/01 21:55:30 brewt Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http.html new file mode 100644 index 0000000..1729e68 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http.html @@ -0,0 +1,495 @@ + + + + +GT::WWW::http - HTTP interface for GT::WWW + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::WWW::http - HTTP interface for GT::WWW

        +

        +

        +
        +

        SYNOPSIS

        +
        +    use GT::WWW;
        +    my $www = GT::WWW->new();
        +    $www->protocol('http');
        +    # any valid GT::WWW methods here
        +    # ...
        +    my $header = $www->header;
        +    $header->header("Some-Http-Header" => $value);
        +    $header->delete_header("Some-Other-Http-Header");
        +
        +    my $response = $www->get() or die "Could not connect to server: " . $www->error;
        +
        +    my $status = $response->status;
        +    my $response_code = int $status; # For example, 200, 404, 500, etc.
        +    my $response_str  = "$status"; # For example, 'OK', 'Not Found', 'Internal Server Error', etc.
        +
        +    if ($status) {
        +        # This will be true if the status code is a successful one - in other
        +        # words, true for 2xx responses, false for others
        +        print "Response successful. Content:\n$response\n";
        +    }
        +    else {
        +        die "Request was not successful ($response_code $response_str)\n";
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::WWW::http handles HTTP connections for GT::WWW. It uses some overloading +to assist in the ease of use without sacrificing functionality.

        +

        This document does not cover the basics of a GT::WWW object; those are covered +by the GT::WWW manpage.

        +

        +

        +
        +

        METHODS

        +

        +

        +

        header

        +

        This method returns the GT::WWW::http::Header object that will be (or has been) +sent to the HTTP server. See the GT::WWW::http::Header manpage for information on using +and manipulating a header object.

        +

        Note that you can add headers without first getting a header object by simply +specifying the headers as arguments to header(). Normally, you would call:

        +
        +    $www->header->header('X-Foo' => 'bar');
        +

        This shortcut allows for:

        +
        +    $www->header('X-Foo' => 'bar');
        +

        Check the GT::WWW::http::Header manpage for valid arguments to the header() method.

        +

        +

        +

        http_10

        +

        This method can be used before initiating a request on the object to force +HTTP/1.0 communication with the HTTP server. By default HTTP/1.1 connections +are used. Note that HTTP/1.1 is strongly recommended as this module supports +keep-alive connections only when using HTTP/1.1. To force HTTP/1.0 +communication, pass a true value to this method, or a false value to use the +default HTTP/1.1 connections. Returns true if HTTP/1.0 connections will be +used.

        +

        +

        +

        strict

        +

        This works as described in GT::WWW. Specifically, in addition to the loose +query string restrictions, this allows relative URL Location: redirects +(HTTP/1.1 specifically states that Location: redirects MUST be absolute).

        +

        +

        +

        no_redirect

        +

        This method is used before a request to indicate that automatic, seemless +redirection should not take place. By default, when a server responds with +an acceptable, properly-formed 3xx response allowing a redirection, this module +will automatically perform the redirection, unless this option has been +enabled. To enable, call this method with a true value, or to disable, a false +value. Returns true if automatic redirection is enabled.

        +

        Note that redirections will only be performed on GET requests.

        +

        +

        +

        redirects

        +

        If redirections are enabled (i.e. the no_redirect option has not been turned +on), you can call the redirects() method to get a list of response objects +created while performing redirections. Typically this will be just one, but +more are possible.

        +

        +

        +

        response

        +

        Returns the response object for the last request. When automatic redirection +is enabled, this will be the response object for the final request. The +response object can be used is multiple ways, which are described below, in the +RETURN VALUES section, and in the GT::WWW::http::Response manpage.

        +

        +

        +

        cancel

        +

        This works as described in cancel in the GT::WWW manpage, with one exception: if cancelling a +request immediately before a redirect takes place, only the current request is +cancelled - the redirect still occurs. Note that cancelling is likely to be a +resource hit in such a case because the connection cannot be reused and a new +one must be established - typically, to the same server.

        +

        +

        +
        +

        RETURN VALUES

        +

        The return values of the get(), head(), +and post() methods are simply the response object for the +request, which can also be obtained by calling the response() +method after completing the request.

        +

        The full documentation for the response object is covered in +the GT::WWW::http::Response manpage, however the below description is provided for a +brief overview. The following examples assume that ``$response'' is an object +that has been obtained by calling get(), head(), post(), or response().

        +

        +

        +

        Status

        +

        The status of the request is available via the ->status method of the response +object. It is made up of three pieces of data - status code, status string, +and success.

        +

        To get the status code (e.g. 500, 200, etc.), simply use the status as a number:

        +
        +    my $status = int($response->status);
        +

        To get the status string (e.g. ``500 Internal Server Error'', ``200 OK''), use the +status as a string:

        +
        +    my $status = "" . $response->status;
        +

        And finally, to get the success of the request, simply use status in boolean +context:

        +
        +    if ($response->status) {
        +

        Success for HTTP is defined by any 200-level response status code. A request +that returns ``200 OK'' will be pass the above if statement, while a request that +returned ``500 Internal Server Error'' will fail.

        +

        +

        +

        Content

        +

        The content of the last request is available by simply using the response +object as a string:

        +
        +    my $content = "$response";
        +

        You should take note, however, that if you are using the +chunk() method no content will be available in this way.

        +

        Also note that the response object is an object, not a string, so anything +beyond basic string comparison/concatenation should not occur on the response +object itself. See CAVEATS in the GT::WWW::http::Response manpage for more details.

        +

        +

        +

        Headers

        +

        The header() method of the response object returns a GT::WWW::http::Header +object which gives you easy access to the headers returned by the server with +the request.

        +

        As a special shortcut, calling header() with arguments will call the +header() method of the header object with the +arguments provided. This allows you to optionally change this:

        +
        +    my $location = $response->header->header('Location');
        +

        into the shorter and clearer:

        +
        +    my $location = $response->header('Location');
        +

        Calling header() without arguments returns the header object for the response.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::WWW manpage +the GT::WWW::http::Response manpage +the GT::WWW::http::Header manpage +RFC 2616: http://www.ietf.org/rfc/rfc2616.txt

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: http.pm,v 1.31 2005/04/08 19:20:00 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Header.html new file mode 100644 index 0000000..8ee2c77 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Header.html @@ -0,0 +1,586 @@ + + + + +GT::WWW::http::Header - Module for GT::WWW::http request/response headers. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::WWW::http::Header - Module for GT::WWW::http request/response headers.

        +

        +

        +
        +

        SYNOPSIS

        +

        Typically:

        +
        +    # Assuming $www is a GT::WWW::http object
        +    my $request_header = $www->header;
        +
        +    # Set a header:
        +    $request_header->header('Some-Http-Header' => 'Header value');
        +
        +    # After making a request:
        +    my $response_header = $www->response->header;
        +    # -- or --
        +    my $response_header = $response->header; # $response is the return of, e.g. $www->get
        +

        Much more advanced headers can be set and determined, using the various methods +available as described below.

        +

        +

        +
        +

        DESCRIPTION

        +

        This module provides an easy to use yet powerful header retrieval/manipulation +object suitable for most HTTP headers.

        +

        +

        +
        +

        METHODS

        +

        First, a note about the methods described which add/change/delete headers: such +methods should only be called on a request header, and only before making a +request. Although nothing prevents you from making changes to the request +header after having made the request, or from changing the headers of a +response header object, such behaviour should be considered very bad practise +and is strongly discouraged.

        +

        +

        +

        header

        +

        This is the most commonly used method as it is used both to add and retrieve +headers, depending on its usage. The examples below assume the following +header:

        +
        +    Date: Sun, 12 Jan 2003 08:21:21 GMT
        +    Server: Apache
        +    Keep-Alive: timeout=15, max=100
        +    Connection: Keep-Alive
        +    Content-Type: text/html
        +    Content-Encoding: gzip
        +    Content-Length: 3215
        +    X-Foo: bar1
        +    X-Foo: bar2, bar3
        +

        With no arguments, a list of all the header names is returned. Given the +example, the following list would be returned:

        +
        +    ('Date', 'Server', 'Keep-Alive', 'Connection', 'Content-Type', 'Content-Encoding', 'Content-Length', 'X-Foo', 'X-Foo')
        +

        With a single argument, a list of value(s) for headers of that name are +returned. In scalar context, only the first value is returned. In list +context, a list of all values is returned. Note that the header named passed +in is case-insensitive.

        +
        +    my $server = $header->header('server'); # returns 'Apache'
        +    my $foo = $header->header('X-Foo'); # returns 'bar1'
        +    my @foo = $header->header('x-Foo'); # returns ('bar1', 'bar2, bar3')
        +

        Finally, when more than one argument is provided, header values are set. At +its simplest level, it takes a list of key => value pairs (NOT a hash, since +duplicate keys are possible) of headers to set. So, to set the headers +'Server' and 'Content-Length' above at once, you could call:

        +
        +    $header->header(Server => 'Apache', 'Content-Length' => 3215);
        +

        Or, if you prefer:

        +
        +    $header->header(Server => 'Apache');
        +    $header->header('Content-Length' => 3215);
        +

        Note that the order in which headers are added is preserved, for times when the +order of headers is important.

        +

        WARNING: Before reading the below information, you should first know that it +describes advanced usage of the header() method and requires have a grasp of +the intricacies of HTTP headers; the following is _not_ required knowledge for +typical GT::WWW use.

        +

        Consider the above Keep-Alive header an example. Instead of specifying:

        +
        +    $header->header('Keep-Alive' => 'timeout=15, max=100');
        +

        you could alternately write it as:

        +
        +    $header->header('Keep-Alive' => [timeout => 15, max => 100]);
        +

        This allows you a more pragmatic approach when you already have some sort of +data structure of the header options. You can go a step further with this, by +specifying undef as the value:

        +
        +    # Set the second X-Foo header in the example:
        +    $header->header('X-Foo' => [bar2 => undef, bar3 => undef]);
        +

        header() also allows you to set values such as:

        +
        +    image/gif;q=0.2
        +

        As can be seen in this example:

        +
        +    Accept: image/png,image/jpeg,image/gif;q=0.2,*/*;q=0.1
        +

        To do so, specify the suboption value as another array reference. The first +element of the array reference is usually undef, while the remaining are the +k=v pairs in the segment. So, in the above header, the 'image/gif;q=0.2' section +would be specified as:

        +
        +    'image/gif' => [undef, q => 0.2]
        +

        (If a segment such as ``foo=bar;bar=foo'' is ever needed, the undef would be +changed to "bar".)

        +

        So, piecing it all together, the Accept header shown above could be specified +like this:

        +
        +    $header->header(
        +        Accept => [
        +            'image/png'  => undef,
        +            'image/jpeg' => undef,
        +            'image/gif'  => [undef, q => 0.2],
        +            '*/*'        => [undef, q => 0.1]
        +        ]
        +    );
        +

        +

        +

        header_words

        +

        When you need to see it a header value contains a particular ``word'', this +method is the one to use. As an example, consider this header:

        +
        +    X-Foo: bar, bar2, bar3
        +

        In order to determine whether or not ``bar2'' has been specified as an X-Foo +value, you could attempt some sort of regex - or you could just call this +method. The return value splits up the header in such a way as to be useful to +determine the exact information contained within the header.

        +

        The method takes a case-insensitive header name, just like the single-argument +form of header().

        +

        A even-numbered hash-like list is always returned - though each element of +that list depends on the content of the header. First of all, if the header +specified does not exist, you'll get an empty list back.

        +

        Assuming that the header does exist, it will first be broken up by ,.

        +

        The even-indexed (0, 2, 4, ...) elements of the list are the keys, while the +odd numbered elements are the values associated with those keys - or undef if +there is no value (as above; an example with values is shown below).

        +

        So, using the above X-Foo header example, calling this method with 'X-Foo' +as an argument would give you back the list:

        +
        +    (bar => undef, bar2 => undef, bar3 => undef)
        +

        Getting a little more complicated, consider the following header:

        +
        +    X-Foo: bar, bar2=foo, bar3
        +

        Because of the ``=foo'' part, the list returned would now be:

        +
        +    (bar => undef, bar2 => "foo", bar3 => undef)
        +

        Quoting of values is also permitted, so the following would be parsed correctly +with '1;2,3=4"5\6' being the value of bar2:

        +
        +    X-Foo: bar, bar2="1;2,3=4\"5\\6", bar3
        +

        Getting more complicated, this method also handles complex values containing +more than one piece of information. A good example of this is in content type +weighting used by most browsers. As a real life example (generated by +the Phoenix web browser):

        +
        +    Accept: video/x-mng,image/png,image/jpeg,image/gif;q=0.2,*/*;q=0.1
        +

        Working that into the X-Foo example, consider this header:

        +
        +    X-Foo: bar, bar2=foo, bar3;foo1=24;foo2=10
        +

        In this case, the value for bar3 will become an array reference to handle the +multiple pieces of information in the third part:

        +
        +    (bar => undef, bar2 => "foo", bar3 => [undef, foo1 => 24, foo2 => 10])
        +

        (If you've read the advanced section of the header() +documentation, and this looks familiar, you're right - the return value of this +function, if put in an array reference, is completely compatible with a +header() value.)

        +

        The undef value at the beginning of the array reference is rarely anything other +than undef, but it could be, if a header such as this were encountered:

        +
        +    X-Foo: bar=foo,foo1=10
        +

        That would return:

        +
        +    (bar => ["foo", foo1 => 10])
        +

        One additional thing to note is that header_words() returns the header words +for all matching headers. Thus if the following two headers were set:

        +
        +    X-Foo: bar, bar2=foo
        +    X-Foo: bar3
        +

        You would get the same return as if this header was set (shown above):

        +
        +    X-Foo: bar, bar2=foo, bar3
        +

        A good example usage of this is for a file download. To get the filename, you +would do something like:

        +
        +    my %cd = $header->header_words('Content-Disposition');
        +    my $filename;
        +    if ($cd{filename}) { $filename = $cd{filename} }
        +    else               { $filename = "unknown" }
        +

        +

        +

        split_words

        +

        This can be called as object method, class method, or function - it takes a +single argument, a string, which it proceeds to split up as described for the +above header_words() method. Note that this knows nothing about header names - +it simply knows how to break a header value into the above format.

        +

        This method is used internally by header_words(), but can be used separately if +desired.

        +

        +

        +

        contains

        +

        This method takes two arguments: a header, and a header word. It returns true +if the header word passed is found in the header specified. For example, the +following would return true:

        +
        +    $header->contains('X-Foo' => 'bar2')
        +

        for any of these headers:

        +
        +    X-Foo: bar2
        +    X-Foo: bar, bar2, bar3
        +    X-Foo: bar, bar2=10, bar3
        +    X-Foo: bar, bar2=10;q=0.3, bar3
        +

        but not for either of these:

        +
        +    X-Foo: bar, bar3=bar2
        +    X-Foo: bar, bar3;bar2=10
        +

        +

        +

        join_words

        +

        join_words() does the opposite of split_words(). That is, it takes a value such +as might be returned by split_words(), and joins it up properly, quoting if +necessary. This is called internally when creating the actual header, and can +be called separately at a method or function if desired.

        +

        +

        +

        delete_header_word

        +

        This takes a header and header word, and proceeds to remove any occurances of +the header word from the header specified.

        +

        After calling:

        +
        +    $header->delete_header_word('X-Foo', 'bar2');
        +

        this header:

        +
        +    X-Foo: bar, bar2;foo=bar, bar3
        +

        would become:

        +
        +    X-Foo: bar, bar3
        +

        +

        +

        delete_header

        +

        This takes a list of header names. The headers specified are completely +removed. +

        +
        +
        +=head2 replace_header
        +

        This 2 or more arguments in exactly the same way as header(), however all the +specified headers are deleted (assuming they exist) before being readded.

        +

        +

        +

        format_headers

        +

        This returns a properly formatted (lines are CRLF delimited) header. If you +use the header as a string (i.e. "$header"), this method will be internally +called, and so generally does not need to be called directly.

        +

        The returned string has the final blank line that identifies the end of the +header.

        +

        +

        +

        clear_headers

        +

        This deletes all headers.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::WWW::http manpage +the GT::WWW manpage +RFC 2616: http://www.ietf.org/rfc/rfc2616.txt

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Header.pm,v 1.8 2004/02/17 01:33:08 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Response.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Response.html new file mode 100644 index 0000000..a840a3f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/http/Response.html @@ -0,0 +1,481 @@ + + + + +GT::WWW::http::Response::Status - Overloaded +response objects for HTTP request data. + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::WWW::http::Response and GT::WWW::http::Response::Status - Overloaded +response objects for HTTP request data.

        +

        +

        +
        +

        SYNOPSIS

        +
        +    # ($www is continued from GT::WWW::http SYNOPSIS)
        +
        +    my $response = $www->get(); # or post(), or head()
        +    # -- or, after having called get(), post() or head(): --
        +    my $response = $www->response();
        +
        +    my $status   = $response->status();
        +
        +    my $content = "$response";
        +    my $response_code = int($status); # i.e. 200, 404, 500
        +    my $response_str = "$status"; # i.e. 'OK', 'Not Found', 'Internal Server Error'
        +    if ($status) { # True for 2xx requests, false otherwise (e.g. 404, 500, etc.)
        +        ...
        +    }
        +

        +

        +
        +

        DESCRIPTION

        +

        GT::WWW::http::Response objects are returned by the get(), +post(), and head() methods of GT::WWW +HTTP requests (and derivatives - i.e. HTTPS), or by calling +response() after having made such a request. The +objects are overloaded in order to provide a simple interface to the response, +while still having all the information available.

        +

        A response object always returns true in boolean context, allowing you to do +things like $www->get($url) or die; - even when a page is empty, or +contains just '0'.

        +

        +

        +
        +

        CONTENT

        +

        In addition to the methods described below, the way to simply access the data +returned by the server is to simply use it like a string - for example, +printing it, concatenating it with another string, or quoting it.

        +

        You should, however, take note that when using the chunk() +option for an HTTP request, the content will not be available.

        +

        +

        +
        +

        METHODS

        +

        For simple requests, often the content alone is enough. The following methods +are used to determine any other information available about the response.

        +

        +

        +

        content

        +

        Returns the content of the HTTP response. Note that this returns the exact +same value as using the object in double quotes.

        +

        +

        +

        status

        +

        Returns the response status object for the request. This object provides three +pieces of information, and has no public methods. Instead, the data is +retrieved based on the context of the object.

        +
        +    my $status = $response->status;
        +

        (N.B. Though the examples below use a $status variable, there is no reason +they couldn't be written to use $response->status instead.)

        +
        +
        numeric status + +
        +

        The numeric status of an HTTP request (e.g. 200, 404, 500) is available simply +by using the status object as a number.

        +
        +
        +
        +    my $numeric_status = int $status;
        +
        + +
        string status + +
        +

        The string status of an HTTP request (e.g. ``OK'', ``Not Found'', ``Internal Server +Error'') is available by using the status object as a string (e.g. printing it, +or concatenating it with another string).

        +
        +
        +
        +    # Assign the status string to a variable:
        +    my $status_string = "$status";
        +
        +
        +
        +    # Print out the status string:
        +    print $status;
        +
        +
        +
        +    # To get a string such as "500 Internal Server Error":
        +    my $string = int($status) . " " . $status;
        +
        + +
        boolean status + +
        +

        In order to quickly determine whether or not a request was successful, you can +use the status object in a boolean context.

        +
        +
        +

        Success is determined by the numeric status of the response. Any 2xx status +(usually 200 OK, but there are others) counts as a successful response, while +any other status counts as a failure.

        +
        +
        +
        +    if ($status) { print "Request successful!" }
        +    else         { print "Request failed!"     }
        +
        + +
        +

        +

        +

        header

        +

        This method, called without arguments, returns the +header object for the response.

        +
        +    my $header = $response->header;
        +

        If this method is called with arguments, those arguments are passed to the +header() method of the header object. This +allows this useful shortcut:

        +
        +    my $some_header_value = $response->header("Some-Header");
        +

        instead of the alternative (which also works):

        +
        +    my $some_header_value = $response->header->header("Some-Header");
        +

        Information on header object usage is contained in the GT::WWW::http::Header manpage.

        +

        Note that although a header object allows for header manipulation, changing the +headers of a response object should be considered bad practise, and is strongly +discouraged.

        +

        +

        +
        +

        CAVEATS

        +

        Although the response object _works_ like a string, keep in mind that it is +still an object, and thus a reference. If you intend to pass the data to +another subroutine expecting a string, it is recommended that you force the +content into string form, either by quoting the variable ("$var") or by +calling the content() method ($var->content). Not doing so can lead to +unexpected results, particularly in cases where another subroutine may +differentiate between a string and a reference, and not just use the value as a +string.

        +

        Also, in terms of speed, obtaining the content (not the object) into another +variable (either via "$var" or $var->content) can make quite a +substantial difference when several string comparison operations are performed. +The reason is simply that every time the object is used is a string, the +content method is called, which can amount to a significant slowdown.

        +

        Although string operations that change the string (i.e. s///) appear to work, +they in fact clobber the reference and turn your variable into an ordinary +string. This should not be done - if the string needs to be modified, take a +copy of it first, and modify the copy.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::WWW manpage +the GT::WWW::http manpage +the GT::WWW::http::Header manpage +RFC 2616: http://www.ietf.org/rfc/rfc2616.txt

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: Response.pm,v 1.8 2004/08/04 19:23:07 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/https.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/https.html new file mode 100644 index 0000000..71d0a44 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/GT/WWW/https.html @@ -0,0 +1,324 @@ + + + + +GT::WWW::https - HTTPS handling for GT::WWW + + + + + + + + + + +

        + + + + + +
        +

        +

        +

        NAME

        +

        GT::WWW::https - HTTPS handling for GT::WWW

        +

        +

        +
        +

        DESCRIPTION

        +

        This module is a simple subclass of GT::WWW::http used by GT::WWW to enable +HTTPS access as opposed to HTTP access. Thus GT::WWW::http should be consulted +instead of this documentation.

        +

        +

        +
        +

        REQUIREMENTS

        +

        GT::WWW HTTPS support requires GT::Socket::Client::SSLHandle, which in turn +requires the Net::SSLeay library.

        +

        +

        +
        +

        SEE ALSO

        +

        the GT::WWW::http manpage

        +

        +

        +
        +

        MAINTAINER

        +

        Jason Rhinelander

        +

        +

        +
        +

        COPYRIGHT

        +

        Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/

        +

        +

        +
        +

        VERSION

        +

        Revision: $Id: https.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/README b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/README new file mode 100644 index 0000000..9fe825f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/README @@ -0,0 +1,2 @@ +These are the help pages, and should not normally need to be edited except for translation purposes. + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/help.html new file mode 100644 index 0000000..5415fa0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/help.html @@ -0,0 +1,169 @@ + + + + + + +

        SlideShow

        +SlideShow turns your Links SQL database into a directory of +photo galleries. When images are uploaded to specific links, they will be +displayed as thumbnails to users browsing your directory, and can be cycled +through like a slideshow. + +

        The SlideShow Plugin Menu

        +SlideShow, like all Links SQL plugins, +can be accessed and customized from the Plugin Manager. Clicking the "Edit" link +beside SlideShow's record in the Plugin Manager brings up a menu of options +allowing you to customize all aspects of your SlideShow plugin.

        + +
        + +Figure 1: The SlideShow Plugin +menu. +

        + +The following options can be configured from the Plugin Details +menu:

        + +Maximum width and height for thumbnail
        +This field controls the +maximum width and height (in pixels) of the thumbnails that will be generated from uploaded +images. Specify using the format widthxheight; 100x200, for example

        + +Maximum width and height for medium sized images
        +This field controls the +maximum width and height (in pixels) of the medium-sized images that will be generated from uploaded +images, allowing extremely large images to be sized appropriately for web display. +Specify using the format widthxheight; 1000x800, for example

        + +Path to watermark file
        +This field allows you to configure a path to a watermark image file. If specified, this +image will appear in the upper-left corner of all medium and full-sizes images in SlideShow. +The image should be small, have a white or clear background, and be in either gif, png or jpeg +format. + +Name of image columns
        +This field contains the +names of the columns from which SlideShow will call and display images. Column +names should be separated by commas. A sample list of column names in this field +might be: "Image_01, Image_02, Image_03, Image_04". Remember to type the names +of the columns exactly as they appear in the "Column Name" +field.

        + +SlideShow images
        +This field contains the names of the +columns from which SlideShow will call and display images when a user is viewing +images in a sequenced slideshow. Column names should be separated by commas. A +sample list of column names in this field might be: "Image_01, Image_02, +Image_03, Image_04". Remember to type the names of the columns exactly as they +appear in the "Column Name" field.

        + +Temporary image +directory +
        This field contains the path to the directory where images will +be temporarily stored while being uploaded.

        + +Image upload +directory
        +This field contains the path to the directory where uploaded +images will be permanently stored.

        + +Menu Options
        +These checkboxes allow you to choose which of the following options will be +displayed in the "SlideShow" menu on the "Installed Plugins" sidebar: Help, Add Fields, + and Edit. + +Plugin hooks
        +The add_link +and modify_link checkboxes allow you to enable and disable the hooks to the +SlideShow plugin in the add_link.html and modify_link.html templates. If +disabled, images uploaded using SlideShow will still be saved and stored +normally, but will not be visible to users viewing the directory. These hooks +are enabled by default, and it is not recommended that you disable them unless +you believe there may be a problem with SlideShow.

        + +

        SlideShow and Your Links SQL Templates

        +To fully integrate +SlideShow into your Links SQL database, you will have to make some changes to +your templates.

        + +To integrate uploaded images into your site, add the +following line to your link.html, detailed.html, or pictureframe.html (click +here for details on this new template) templates, depending on which pages you +want to be able to display images on:

        + +
        <%Plugins::SlideShow::generate_paths($ID)%>
        + +To let users to be +able to upload images of their own to your database, make the following changes +in form.txt:

        + +replace

        + +
        <form method="POST" name="admin" action="add.cgi" >
        + +with

        + +
        <form method="POST" enctype="multipart/form-data"  name="admin" 
        +action="add.cgi" >
        + +To make the file upload fields available to users, +add the following to form.txt, replacing "COLUMN_NAME" with the name of the +columns you wish to add:

        + +
        <input type="file" name="COLUMN_NAME">
        + +So, if you had a series +of columns called "Image1", "Image2", etc, you would add the following to +form.txt:

        + +
        <input type="file" name="Image1">
        +<input type="file" name="Image2">
        +<input type="file" name="Image3">
        +<input type="file" name="Image4">
        +<input type="file" name="Image5">
        + +To actually display the uploaded +images, add the following line (replacing "Image1" with the name of the desired +columns) to your link.html, detailed.html, or pictureframe.html (click here for +details on this new template) templates, depending on which pages you want to +display images on. You will have to add the line once for each column, inserting +the column name for each:

        + +
        <img src="<%Image1_path%>">
        + +To display thumbnails of the +uploaded images, add the following line (replacing "Image1" with the name of the +desired columns) to your link.html, detailed.html, or pictureframe.html (click +here for details on this new template) templates, depending on which pages you +want to display thumbnails on. You will have to add the line once for each +column, inserting the column name for each:

        + +
        <img src="<%Image1_thumbnail_path%>">
        + +To create a link to +the slideshow, allowing users to view images in their full size, enter the +following (replacing Image1" with the name of the image column you want the +slideshow to begin with):

        + +
        <a href="<%db_cgi_url%>/showpicture.cgi?ID=<%ID%>&v=Image1">text of link</a>
        + +You +may wish alter this code in case the column called in the above string does not +contain any data. The following code will create a link that will open the +slideshow, search the image columns and display the first image found.

        + +
        <%if first_img_col%>
        +<a href="<%db_cgi_url%>/showpicture.cgi?ID=<%ID%>&v=<%first_img_col%>">text of link</a>
        +<%endif%>
        + +If, for example, no file was found in the Image1 column, +but a file was contained in the Image2 column, the slideshow would automatically +display the file in the Image2 column first.

        + +Installing SlideShow +automatically generates a new template called slideshow.html that builds the +slideshow page in which users can browse through uploaded images. By modifying +this template, you can alter the way in which users view +images.
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/screenshot.gif b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/screenshot.gif new file mode 100644 index 0000000..bb0ae3e Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/SlideShow/screenshot.gif differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_admin.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_admin.html new file mode 100644 index 0000000..2ce0096 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_admin.html @@ -0,0 +1,115 @@ + + + + +Gossamer Links Help: Admin + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Admin +Overview +

        +

        Your admin panel gives you complete control over all aspects of your Gossamer Links +directory. From here you can do everything: from editing templates to downloading +plugins to changing your system settings.

        +

        The admin panel is broken up into 10 major headings:

        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        HomeThis returns you to the main Gossamer Links page that you first arrived at. + It also has the Quick Links toolbar which you can customize and place your + most commonly used links for quicker reference.
        BrowseThe Browse menu gives you a graphic representation of your directory. You can quickly + browse your category structure, move categories around, move links around, + validate links, create category relations and assign new category editors.
        DatabaseFrom Database you can + access your database in the traditional view of searching and displaying + records. You can also validate links, verify and check links, and have + access to a number of useful tools like MySQLMan.
        BuildOne of the main features of + Gossamer Links is its ability to generate static HTML pages. The build menu + lets you create static HTML pages, plus control the entire look of your + site. From the template editor you can change the templates that build the pages of your + directory, and from the language editor you can alter any language-specific words.
        EmailGossamer Links provides you with a powerful and versatile Mass Mailer that can be used to send email to all or select groups of users. From here you can email people in your + directory, email newsletters of new links, and even maintain custom + mailing lists.
        PluginsPlugins allow you to enhance Gossamer Links with just a few clicks. You + can connect to Gossamer Threads and download the latest plugin, or even + use the wizard to create new plugins.
        PaymentsThe Payments menu allows you to configure your Gossamer Links installation to accept payments from your users for listing their links for defined periods of time. Paid links will be displayed above unpaid links in your directory.
        SetupAll your program + configuration is stored here. Everything from your SQL setup, to Build + options. You should have a look through to see all the different ways you + can configure Gossamer Links.
        StaticThis link will take you to + your main page. It will be a 404 error until you build your directory for + the first time.
        DynamicGossamer Links can also display + your directory dynamically! Clicking here will take you to the page.cgi + script which displays your directory on the fly. 
        HelpClicking on help gives you + context-sensitive help.
        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_browse.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_browse.html new file mode 100644 index 0000000..3226b7b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_browse.html @@ -0,0 +1,102 @@ + + + + +Gossamer Links Help: Browser + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Browse Help

        +

        The category browser is a + simple way to manage your database. The browser lets you easily manage large + category trees by just pointing and clicking. For small databases (less then + 200 categories), the browser will load all your categories into memory and + you can expand any section of the tree immediately. For larger databases, + only the top level categories are loaded, and clicking on the arrow icons + will fetch the selected subcategories and expand the category you want.

        +

        Clicking on +the Root folder will give you the option of adding a sub-category.  You can continue adding as many sub-categories as deep as you wish, there +is no pre-set limit to the number of drill-down levels, simply your estimation +of the user’s patience. + +

        +

        Clicking on a category, will + give you a list of all links inside that category in the right frame, plus + options for the following:

        +
          +
        • Browse: This displays a + list of links within the category, and is what you see by default.
        • +
        • Add Sub Category: This + takes you to an add form that lets you create a sub category.
        • +
        • Add Link: This takes you + to an add form that lets you add a link in this category.
        • +
        • Edit: This lets you + change any field for the current category
        • +
        • Delete: This lets you + delete the current category. Warning: deleting a category will + delete all links inside that category, plus all sub categories!!
        • +
        • Move: This lets you move + the category to another part of the tree. To move the category simply + click "Move", and then click on the category you want to move to. 
        • +
        • Editors: Clicking "Editors" brings up a menu allowing you to create and delete editors. Editors are users who are given select administrative control over a category and it's sub categories. When an editor logs in, an "Editors" link will be displayed along with the other links on the directory home page. Clicking this link will display an Admin Panel, giving the editor access to the categories and options assigned to them.
        • +
        • Related: You can setup + category relations by clicking on related. From here, just click on the + category you want this to be related to and it will appear in the list. + To stop, simply hit cancel.
        • +
        +

        From here you can also edit + the links that are in this category. You can:

        +
          +
        • Update: This link only + shows up if the link has been updated by a user, and the changes have + not yet been validated. Clicking on this will let you approve or reject + the changes the user made. Note: you can also do this by clicking on + Changed Links in the Database menu.
        • +
        • Validate: This link only + shows up if the link has been added by a user, and is not yet validated. + Clicking on this will let you view the link and determine if it should + be added into the database or not, or if it belongs in a different category than the one selected by the user. Note: you can also do this by + clicking on Validate Links in the Database menu.
        • +
        • Edit: This takes you to a + modify form where you can change any attribute of the link.
        • +
        • Delete: This lets you + delete the link.
        • +
        • Move: This lets you move + the link to a different category. Simply click on "Move", then click on + the link you want to move it to.
        • +
        • Copy: This lets you copy + a link to a different category. Simply click on "Copy", then click on the + category you want to copy the link to.
        • +
        • Owner: Clicking "Owner" will display a list of all links owned by the user who owns the selected link.
        • +
        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_build.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_build.html new file mode 100644 index 0000000..c98f870 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_build.html @@ -0,0 +1,94 @@ + + + + +Gossamer Links Help: Build + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Build Help

        +

        The Build menu allows you to create HTML pages from your Gossamer Links directory, and control the appearance of those pages. Separate HTML pages are created for each category and index (such as the "What's New", "What's Cool" and "Top Rated" indexes). The "HTML Pages" options provide you with three different ways of creating HTML pages: "Build Changed", "Build All", and "Build Staggered". Clicking the "Dynamic" link in your admin panel allows you to view your directory without performing a build; for very +large directories, this can actually be better, as page.cgi is very fast, and +works well under mod_perl. The "Templates" options let you edit the templates from which the directory's HTML pages are created. The "Diffs" section provides listings of the changes that have been made to Gossamer Forum's templates as the program has been updated. + +

        +

        To generate your HTML pages you +have three options: + +

        +
          +
        • Build Changed: Clicking the "Build Changed" link creates the "What's New", "What's Cool", "Top Rated" and home pages. Next, it will create only those categories and pages of links that have changed since the last time the pages were built.
        • +
        • Build All: Clicking "Build All" will create all of the HTML pages in your database.
        • +
        • Build +Staggered: Clicking "Build Staggered" will create all of the HTML pages in your database, but will perform the build incrementally, performing a series of small builds one at a time in order to avoid resource allocation problems in large databases.
        • +
        +

        All the pages in Gossamer Links are +controlled through the use of templates. You can manage your templates from +within the build menu. + +

        +
          +
        • User Templates: Clicking "User Templates" allows you to edit the templates that create your database's HTML pages. By altering these templates, you can customize the appearances and functions of the HTML pages that make up your directory. Multiple template sets can be saved; you can update and modify one template set while displaying another to your users, allowing you to perform upgrades without inconveniencing or confusing users, as well as offering your users multiple directory interfaces. To view a list of all tags that can be used in a specific template, add the following tag to the desired template:

          + +<%GT::Template::dump%>

          + +Open the page built by the template (you may have to refresh it as well), and a list of all tags that can be used in that template will be displayed. For more information on customizing your Gossamer Links directory using the template menus, as well as a complete list of all Gossamer Links user template, see "Templates" in the "Customizing Gossamer Links" section of the Gossamer Links manual. +
        • + +
        • User Language: If you are +using Gossamer Links on a site that is not written in English, you can change the +user-viewable language here at the “User Language” option.  This feature greatly simplifies the translation of a Gossamer Links +application in a foreign language by giving all Descriptions a code that is used +throughout the program.  Change it +once and all the changes will be applied to all applications throughout the +program where the code is used.
        • +
        • Template Globals: Clicking "Template Globals" allows you to edit Gossamer Links's globals. Globals are HTML tags which can be used in all templates. By editing and adding globals, you can configure frequently used tags to be quickly and easily inserted into any template you wish.
        • +
        +

        Working With Templates
        +
        The Gossamer Links template system is very easy to work with. Basically, when a + user does something like views a category, the program gets the appropriate + template (category.html in this case) and parses it. It then displays the + output to the user. Gossamer Links will print out exactly what's in the template, + but replace anything found in between <% and %> tags with the appropriate values. You can also include other + template files within other templates, allowing you to maintain seperate header and footer files that will be displayed on most pages. Please see the GT::Template + documentation for more information on the syntax as well as "Templates" in the "Customizing Gossamer Links" section of the Gossamer Links manual.
        + +

        + +

        FileMan
        +
        FileMan is a web-based File Manager that allows you to manage your directory without using FTP, and is bundled with Gossamer Links. FileMan contains its own separate help documentation. Note: It is recommended that FileMan only be used by those familiar with editing text files. Additional information about FileMan can be found in the "FileMan Forum" and the Gossamer Threads site.

        + + +

        Diffs
        +The Diffs menus provide detailed descriptions of how Gossamer Links's templates have been updated since the program's creation. The 2.0.3-2.0.4 menu, for example, will list all of the HTML that was added to Gossamer Forum when version 2.0.4 was released, as well as all of the HTML that was removed in that version from version 2.0.3. HTML that was added is indicated by a plus (+) symbol; HTML that was removed is indicated by a minus (-) symbol. The "Extra Template Diffs" show template updates for the additional template sets (av, mint, simple, snap, yahoo). + +

        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_database.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_database.html new file mode 100644 index 0000000..39dda84 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_database.html @@ -0,0 +1,91 @@ + + + + +Gossamer Links Help: Database + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Database Help

        + +

        The database screen has two +components: the database editor, and database tools.

        + +

        Database Editor
        +
        The database editor is a powerful tool that lets you manage the contents of +the four main tables in Gossamer Links: Categories, Links, Users and Reviews.

        + +

        To use the editor, you first +select the table you want to work with:

        +
          +
        • Category: The Category table records + your category structure and controls how your categories are linked + together
        • +
        • Links: The Links table records your + link information, and also which links are in which categories.
        • +
        • Users: The User table is your user + database.
        • +
        • Reviews: The Reviews table contains reviews users have written and attached to links they wish to comment on.
        • +
        +

        The second +Pull-down menu gives you a list of the various options and actions you can perform on each of +the three tables in the first menu. Choosing "Add", "Modify", "Delete" or "Search" will provide a form allowing you to perform the desired action. Choosing "List All" displays a summarized list of all records in the specified table. Selecting "Properties" opens the Table Editor, which lets you alter the table and add new columns, delete columns or import/export data (see below).

        +

        The third box is optional, and allows you to quickly find a specific record when +searching. For +Links, Categories and Reviews enter the numeric ID of the desired record. For Users, enter the username of the desired record. +If you choose Search, Delete or Modify and enter a value in the box, the specified record will be displayed automatically. The box is ignored when Add, List All or Properties is selected.

        + +

        Table Editor
        + Selecting any of the four record types and "Properties" in the Database Editor displays the Table Editor, which allows you to edit the columns of the selected record type's table. Each of these columns represents one of the columns that define and describe records (ID, Description, Owner, etc.). The Categories, Links, Users and Reviews Table Editors have different columns, and will look slightly different from each other.

        + +

        Clicking on a "Column Name" brings up a detailed form allowing you to edit that specific column (for a complete description of the fields in the Table Editor, see the "Adding Columns" section of the Gossamer Links manual). The "Indexing Scheme" drop-down menu allows you to choose from four indexing schemes: INTERNAL, MS SQL, MYSQL and NONINDEXED (see the "Indexing Scheme" section of the manual for details). Beneath the "Indexing Scheme" menu is a small menu that provides you with other tools for editing the table: "Add Column", "Delete Column", "Import Data", "Export Data", and "Resync Database". For more information on customizing your Gossamer Links directory using the columns menu, see "Columns" in the "Customizing Gossamer Links" section in this manual. + +

        Database Tools
        + Included in this menu are several tools to help you manage your database.

        + +
          +
        • Validate Links: Clicking on "Validate Links" brings up a list of all links that have been added by users but not validated by administrators, and allows you to validate or delete them.
        • +
        • Validate Changes: Clicking on "Validate Changes" brings up a list of all link modifications that have been made by users but not validated by administrators, and allows you to either approve or reject the changes made by the user.
        • +
        • Validate Reviews: Clicking on "Validate Links" brings up a list of all links that have been added by users but not validated by administrators, and allows you to validate or delete them.
        • +
        • Verify Links: Clicking on "Verify Links" allows you to verify any or all of the links in your database. A menu will display the statuses of all links in your database. Select the type of links you want to verify ("Haven't been checked for X days", "Unchecked Links", "Everything"), and click "Verify Links". Depending on the size of your directory and the verification option you have selected, the process can take some time. See "Link Status" for descriptions of the various status codes that will be displayed beside each link. Note: If you have an extremely large database, you will need to run nph-verify.cgi from telnet, not the web. It is also recommended that you set up your system to run nph-verify.cgi nightly to automatically check links that haven't been checked in seven days.
        • +
        • Link Status: Clicking on "Link Status" will display the status of all links in your database and allow you to delete or modify links that are no longer valid. You have the option of modifying or rechecking specific links, or deleting or rechecking all links with a certain status.
        • +
        • Check Duplicates: Clicking on "Check Duplicates" will check your directory for links that have the same URL. You can modify any of these links by clicking the appropriate link, or delete them by checking the boxes beside them and clicking the "Delete Selected" button.
        • +
        • Purge Expired Links: Clicking on "Purge Expired Links" allows you to delete paid links that have expired. Enter the minimum number of days since expiry (entering 10 will delete all links that expired 10 or more days ago) and click the "Purge Links" button.
        • +
        • Import/Export: Clicking on "Import/Export" allows you to import data from previous versions of Links, create backup files and restore Links from backup files. Note: on large databases, you should run this from shell/telnet + as it can take a while to run.
        • +
        • MySQLMan: MySQLMan is an SQL utility that comes bundled with Gossamer Links, which contains its own separate help documentation. Note: It is recommended that MySQLMan only be used by those familiar with editing SQL files. Additional information about MySQLMan can be found in the "MySQLMan Forum" and the Gossamer Threads site.
        • +
        • SQL Monitor: The SQL Monitor allows you to input raw queries directly to your database. This is provided as a convenience feature for advanced users only. You must be familiar with SQL to use this. Note: Be careful while using the SQL Monitor. Gossamer Links cannot undo any changes you make through the SQL Monitor.
        • +
        • Rebuild Search: Clicking "Rebuild Search" will re-index your Gossamer Links database. This is only necessary if you have changed search weights, or if the database has been manually changed from outside of Gossamer Links itself.
        • +
        • Repair Tables: Clicking "Repair Tables" will check that your database's category counts are correct. Link statuses (such as New and Cool) will be updated, as well as ratings and hit counts.
        • +
        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_editors.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_editors.html new file mode 100644 index 0000000..f5cf2e8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_editors.html @@ -0,0 +1,74 @@ + + + + +Gossamer Links Help: Database + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Editors Help

        + +

        Editors are a powerful new + feature of Gossamer Links. They allow you to off load the maintenance of your + directory to other users without having to give them access to your admin. + With Editors, you can give users the ability to add, modify, delete, + validate links as well alter the category structure.

        +

        To use editors, you need to + make sure your template set you are using contains the browser_* templates. + These templates control the look and feel of the editor system. You can + tweak these to make it fit into your site, however be careful not to alter + the JavaScript unless you know what you are doing.

        +

        To assign an editor control + over a category, simply click on Browse, pick the category you want, and + click on Editors. Then type in the username (must be a valid user that + already exists) and select what permissions the editor has over the + category. Hit submit, and you are done.

        +

        Now, that user can log in + from the user.cgi script. Once logged in, you can present them with a link + to admin.cgi, and they will be presented with the same browse window you + see from the admin, however it will be rooted at the category you selected. + They will not be able to access any part of the category tree outside of + their own category.

        +

        From there, the editor can + add, modify, delete links, validate new links, etc. It all works exactly the + same as how the admin system works.

        +

        Also included is a tag for + displaying editors. If you add:

        +

        <%Links::Utils::load_editors%>
        + <%if editors%>
        +    The following users maintain this category: <%editors%>
        + <%endif%>

        +

        To your category.html + template, then you will be able to see a list of editors available in the + selected category. 

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_email.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_email.html new file mode 100644 index 0000000..1406d98 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_email.html @@ -0,0 +1,79 @@ + + + + +Gossamer Links Help: Email + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Email Help

        + +

        Gossamer Links provides you with a powerful and versatile Mass Mailer that can be used to send email to all or select groups of users. The Mass Mailer can also create custom emails updating users on the status of their links, and create and edit templates for commonly sent emails. The "Custom Lists" tools allow you to create and manage mailing lists of specific addresses, while the "Current Mailings" menu provides a simple yet effective tool for reviewing and sending all mailings. + +

        +

        The Mass Mail options allow you to write and send email to whichever users you choose. There are four ways in which mass mails can be composed: "All Users", "All Links", "Selected Users" and "Selected Links" (remember to send mailings composed in these menus from the "Current Mailings" menu). The "Newsletter" option lets you customize and send automatically generated updates to your users informing them of new additions to your directory. + +To personalize mailings being sent to more than one recipient, you can insert any of the fields in the Users Table into the mailing by using tags. For example: typing <%username%> or <%email%> in the body of the mailing will insert each user's username or email address into their individual copy of the mailing. Ensure that the field actually does exist in the database and that you've properly copied the spelling and casing, or an unknown tag error will appear. + + +

        +

        All Users: The "All Users" option allows you to send email to all users who have agreed to accept email from your directory, as directed by the "ReceiveMail" column in the Users Table. You can see the complete list of these users by clicking the link displaying the number of email recipients at the top of the email composition form. + +

        +

        All Links: The "All Links" option allows you to send email to all link owners who have agreed to accept email from your directory. You can see the complete list of these users by clicking the link displaying the number of email recipients at the top of the email composition form. Since an "All Links" email will be sent to each link, users who own more than one link will receive multiple emails. + +

        +

        Selected Users: The option +to mail a list of Selected Users will display a Search Form that +will help you select a specific list of Users with specific attributes.  A short cut has been provided to you here with the pull-down menu for the +Status field.  You can choose to +email all the users registered as Editors here and only those users.  Alternatively, you can also email all the non-validated users who may be +neglected for a period of time while your site is down for maintenance possibly.  +You can also use any of the other search fields to help you narrow down +your search for selected users to email. + +

        +

        Selected Links: The "Selected Links" option allows you to send email to link owners who fit the results of a search. A "Selected Links" email will be sent for each selected link, so users who own more than one of the selected links will receive multiple emails. + +

        +

        Newsletter: The "Newsletter" option allows you to create, edit and send a newsletter informing users who have agreed to receive it of developments within your directory. To view the users designated to receive the newsletter, click the link displaying the number of email recipients at the top of the newsletter form. The default newsletter template is a list of all links in the "What's New" index (to change the number of days that a link will be kept in the "What's New" index, change the "build_new_cutoff" field in the "Build Options" section of the "Setup" menu). The list of links will be compiled in chronological order, with the most recently added links appearing at the bottom of the list. You can alter the way in which the newsletter's list of new links is compiled, as well as the name and email address the newsletter will be sent from by clicking the "Edit newsletter template" link. + +

        +

        Custom Lists: The Custom Lists options will allow you to create, modify and delete mailing lists, as well as send mail to those lists. + +

        +

        Current Mailings: Clicking "View" displays the "View Mailings" menu, which displays current and recently completed mailings. Click the "Start Mailing" link next to an unsent mailing to send it. Click the "Details" link next to a mailing to review its recipients and content. Click the "Cancel mailing" link next to an unsent mailing if you wish to cancel the mailing. You will be presented with the option of either confirming or aborting the cancellation of the mailing, as well as the details of the mailing. Click the "Delete mailing" link next to a completed mailing if you wish to permanently delete it from the "View Mailings" menu. You can also delete all completed mailings and cancel/delete all current mailings from the "View Mailings" menu by clicking on the appropriate links at the bottom of the menu. You will be prompted to either confirm or abort all deletions and cancellations. + + +  +

        +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide.html new file mode 100644 index 0000000..2107c56 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide.html @@ -0,0 +1,72 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Gossamer Links Developers Guide

        +

        Notice: This section is + intended for people looking to understand the internals of Gossamer Links, and + how to extend and enhance the program.

        +

        Gossamer Links is a very modular + program, and was designed from the ground up to offer a lot of flexibility + to the end user. The goal of this guide is to make you aware of how Links + SQL works and how you can best extend or enhance it.

        +

        Included is an overview of + how the plugin system works, and how you can extend Gossamer Links, plus a + reference of the ins and outs of everything that makes up Gossamer Links.

        +

        Enhancing + Gossamer Links Easily

        +

        Understanding Plugins

        +
        +

        The + Install File

        +

        Plugin + Hooks

        +

        Sample + Plugin: Search Cache

        +

        More Samples to Come ...

        +
        +

        Reference

        +
        +

        Database Structure

        +

        Core + Files and Variables

        +

        GT + Module Documentation

        +
        + +

        mod_perl Setup

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_enhance.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_enhance.html new file mode 100644 index 0000000..f144eb2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_enhance.html @@ -0,0 +1,220 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Gossamer Links Developers Guide + : Enhancing Gossamer Links

        +

        There are many different + ways you can enhance Gossamer Links. Plugins are the most advanced way and is a + great way to share your addition with others. However, if you just need to + add some code, or alter Gossamer Links so it works for you, there are a couple + different things you can do.

        + +

        Running Custom Code:
        +
        Before you get into Plugins, + you may not even need them! The template system provides a robust way of + adding your own code to Gossamer Links.
        You can do this in one of two ways:

        + +

        1. Go to Build->Template + Globals and you can add a perl subroutine. For instance, to display a list of the + top 5 links you could do:

        + +
        + + + + +
        +
        sub {
        +	my $vals = shift;
        +	my $link_db = $DB->table ('Links');
        +	$link_db->select_options ('ORDER BY Hits DESC', 'LIMIT 5');
        +	my $sth    = $link_db->select;
        +	my $output = '';
        +	while (my $link = $sth->fetchrow_hashref) {
        +		$output .= Links::SiteHTML::display('link', $link);
        +	}
        +	return $output;
        +}
        +
        +
        +

        The first argument is a hash + ref of tags that are already available on this page. Your function can + either return a hash ref making new tags available, or return HTML that will + be displayed to the user. In our case we simply queried the database, + formatted the top 5 links and returned the output.

        + +

        + Be sure to view our resource center + for a list of globals users have created that you can easily add. +

        + +

        2. Create your own module + with functions, and reference it:

        + +

        <%Yourmodule::somefunc%>

        + +

        and it will run somefunc + that should be found in Yourmodule.pm. Same rules apply.

        + +

        Adding Custom Fields:
        +
        Adding fields is easy in Gossamer Links. To add a new field to the Links + table, simply click on Database->Links->Properties. Then at the bottom + click on Add Column. This will present you with the following options:

        + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Column + Name This is the + name of the column, and must be a valid SQL name (so no + spaces, etc.)
        Column + Type This is a + select list of what type of data you will store. If you need + more then 255 characters, you should use a TEXT field.
        Column + Size This is the + length of the field and is only required for CHAR types.
        Column + Values
        + (Only for ENUM fields)
         If you are + using an ENUM (enumerated) type, then you need to enter the + values here. One value per line. For instance if you wanted to + add a column Status that could have values 'Cool', 'New', + 'Popular', 'Reviewed' only, then you would enter those values + her, one per line.
        Not + Null Set + to Yes if the user must enter a value, if set to no, the + column can be left blank.
        Default Enter the + default value here, this will be what is shown when the user + clicks on add.
        Form + Display If your column + is named foo_bar then you can enter a pretty name that is used + when displaying the column (such as 'My New Column').
        Form + Type A select list + of what type of form you want to use to display this field: + checkboxes, radio buttons, textareas, etc.
        Form + Size The SIZE + attribute of the form, this determines how large the form + appears in the admin.
        Form + Names
        + (Stored in Database)
         If + the form type is a select or checkbox, this list controls what + names are stored in the database. 
        Form + Values
        + (Displayed on Form)
         If + the form type is a select or checkbox, this list controls what + values are displayed to the user.
        Form + Regex You can enter a + regular expression that all input must pass before being + submitted.
        Search + Weight This controls + whether the field is searchable by the user. The higher the + number, the more important the result is.
        +
        +

        When you hit submit, the + column will automatically appear in your Admin, and be available on your + templates as <%ColumnName%>. You must manually add it to the add and + modify forms for it to be available to users.

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_hooks.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_hooks.html new file mode 100644 index 0000000..263876b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_hooks.html @@ -0,0 +1,414 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Developers Guide: + Plugin Hooks

        +

        This + section describes all the hooks available in Gossamer Links.

        +

        Searching 

        +

        Adding

        +

        Modifying

        + +

        Templates

        + +

        ...

        + +
        + +

        Searching

        + + + + + + + + + + + + + + + + + + + + + +
        Name:search_results
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for search_results.html template.
        + On failure: tags required for search_failure.html + template. +
        Triggered + On:search.cgi + being run with query=something being passed in.
        Description:This hook + is run whenever a search is run, and it generates a list of search + results that will be sent to the success or failure templates + depending on whether error => 'message' is a key in the hash that + is returned.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_search_results
        PRE + Input:HASH REF:
        +   link_results => html formatted list of matching links,
        +   category_results => html formatted list of matching links,
        +   link_hits => total number of links matched
        +   cat_hits => total number of categories matched
        +   next => a formatted html toolbar or empty if not that many + results
        +   term => a url escaped version of what the user searched for
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:search.cgi + being run with some results being found. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_search_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why no results + were found
        +   term => a url escaped version of what the user searched for
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:search.cgi + being run with no  results being found. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + +

        Adding Links

        + + + + + + + + + + + + + + + + + + + + + +
        Name:add_link
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for add_success.html template.
        + On failure: tags required for add_failure.html + template. +
        Triggered + On:add.cgi + being run with add=something being passed in.
        Description:This hook + is run whenever the add_form is submitted, and it adds a link to the + Links table, and emails the administrator that a link is awaiting + validation.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_add_success
        PRE + Input:HASH REF:
        +   A complete hash ref of the new link that was added which + includes all columns defined in the Links table, plus:
        +   Category => a newline separted string of Category Names that + this link was added too.
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:add.cgi + being run and the link being successfully added.
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_add_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why link could + not be added
        +   Category => a select list/hidden field for use in category + form.
        POST + Input:SCALAR: + Fully formatted HTML page showing search results.
        Triggered + On:add.cgi + being run, with errors in the submission. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + +

        Modifying Links

        + +

        + + + + + + + + + + + + + + + + + + + + + +
        Name:modify_link
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for modify_success.html template.
        + On failure: tags required for modify_failure.html + template. +
        Triggered + On:modify.cgi + being run with modify=something being passed in.
        Description:This hook + is run whenever the modify_form is submitted, and it either changes a + link in the Links table, or records the change awaiting validation.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_modify_success
        PRE + Input:HASH REF:
        +   A complete hash ref of the new link that was changed which + includes all columns defined in the Links table, plus:
        +   Category => a newline separted string of Category Names that + this link was placed in.
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:modify.cgi + being run and the link being successfully changed.
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_modify_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why link could + not be added
        +   Category => a select list/hidden field for use in category + form.
        POST + Input:SCALAR: + Fully formatted HTML page showing search results.
        Triggered + On:modify.cgi + being run, with errors in the submission. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + +

        Templates:

        + + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_[template + name]
        PRE + Input:HASH REF + of template tags available.
        POST + Input:SCALAR: + Fully formatted HTML page showing parsed template.
        Triggered + On:Any time + output is displayed to the user, it's through a template.
        Description:Any + template can be overriden by using the hook site_html_template_name. + So if you want to override the displaying of a link, you would do + site_html_link.
        + +

         

        + + + + + +
        +Table +of Contents +
        + + + + + +
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs.html new file mode 100644 index 0000000..7932a78 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs.html @@ -0,0 +1,11 @@ + + +Gossamer Links Help - GT Library + + + + +You need a frames capable browser to view the library help online. + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs_top.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs_top.html new file mode 100644 index 0000000..f47bbb2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_libs_top.html @@ -0,0 +1,19 @@ + + +Gossamer Links Help - Table of Contents + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_core.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_core.html new file mode 100644 index 0000000..c6ae15e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_core.html @@ -0,0 +1,204 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Links + SQL Developers Guide: Core Files and Variables

        +

        Any Gossamer Links script will + start out with:

        + +
        	use strict;
        +	use lib '/path/to/admin';
        +	use Links qw/$IN $DB/;
        +	Links::init ('/path/to/admin');
        +	Links::init_user(); 
        + +

        The lines mean:

        + +
          +
        • use strict - + Required to avoid common mistakes and enforce good programming + practices. 
        • +
        • use lib '/path/to/admin' + - Tells Gossamer Links where it is installed.
        • +
        • use Links qw/$IN $DB/; - + Loads Gossamer Links and makes $IN and $DB variables available in this + script.
        • +
        • Links::init + ('/path/to/admin'); - Initializes Gossamer Links.
        • +
        • Links::init_user(); - + Optional, only needed if this is a user side script. It loads the + current user into $USER.
        • +
        +

        + The variables available for use are:

        + + + + + + + + + + + + + + + + + + +
        $INA GT::CGI + object, stores all the form input and behaves very close to CGI.pm
        $DBA GT::SQL + object. This is used to access and store any data Gossamer Links needs.
        $CFGThe Links + SQL Config file. It's a hash of all the configuration options used.
        $USERA hash of + the currently authenticated user. If Gossamer Links is unable to + authenticate the user, then this variable will be undefined.
        +

        These objects are globals + and will be automatically imported into your namespace.

        + +

        The following is a summary + of what the main modules in Gossamer Links do:

        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Links.pmContains the main code + to initilze the globals needed, plus very commonly used routines like + page parsing, and error handling.
        Links::AuthenticateContains code used to + modularize the user system. If you are looking at making Gossamer Links + share a common user base with another program, then this is the area + you want to change.
        Links::BrowserContains code to manage + the category browser.
        Links::BuildContains code to do the + calculations neccessary to build a section of Links. i.e. calculation + neccessary to get a list of What's New links. Does not actually build + the final html, just returns a hash of template variables.
        Links::ConfigContains code to manage + your config file. Provides methods to load, save and alter your config + file.
        Links::Config::DataStores just the hash of + your current config options. This gets parsed everytime a new config + object is created.
        Links::HTML::CategoryThis is a subclass of + GT::SQL::Display::HTML::Table which contains code used when displaying + a category in the admin panel.
        Links::HTML::LinksThis is a subclass of + GT::SQL::Display::HTML::Table which contains code used when displaying + a link in the admin panel.
        Links::HTML::UsersThis is a subclass of + GT::SQL::Display::HTML::Table which contains code used when displaying + a user in the admin panel.
        Links::ParallelThis manages running + the link checker in parallel.
        Links::PluginsA simple frontend to + the plugin interface. The bulk of the work is in GT::Plugins.
        Links::SiteHTMLThis contains all the + display information. Each screen that you see is a subroutine in here + and is used to parse the template and return the printed page.
        Links::SQLThis contains the GT::SQL::Creator + code necessary to generate the SQL tables.
        Links::Table::CategoryThis is a subclass of + GT::SQL::Table + and contains code that needs to be run every time a category is added, + altered or deleted.
        Links::Table::LinksThis is a subclass of + GT::SQL::Table + and contains code that needs to be run every time a link is added, + altered or deleted. Also contains the code for display a link in the + admin.
        Links::Table::UsersThis is a subclass of + GT::SQL::Table + and contains code that gets run everytime a user is added, altered or + deleted.
        Links::ToolsThis contains a variety + of useful tools found in the admin templates.
        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db.html new file mode 100644 index 0000000..c5bcb14 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db.html @@ -0,0 +1,331 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Links + SQL Developers Guide: Database Structure

        +

        The Gossamer Links database is made up of several tables. The main three + tables that hold all the data are: Links, Category and + Users. The definition + of the tables are show below. They use mysql syntax for the types, but + GT::SQL will map these to the best type in other databases.

        + +

        The tables are joined + together as follows:

        + +
        + + + + +
        +
        +

        Note: These + represent the core tables. There are a few other for managing mailing lists + and tracking the status of links, but these are the primary ones.

        + +

        The + descriptions for the main three tables are below:

        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Links
        ColumnTypeNotes
        IDINTPrimay Key, auto incremented integer
        TitleCHAR(100)Title of the link
        URLCHAR(255)URL of the link
        LinkOwnerCHAR(50)Foreign key to Users table. Represents + user who owns this link.
        Add_DateDATEDate the link was added
        Mod_DateDATEDate the link was last changed
        DescriptionTEXTA description about the link
        HitsSMALLINTNumber of time the link has been clicked + on
        isNewENUM('Yes','No')Flag saying whether the link is new
        isChangedENUM('Yes','No')Flag saying whether the link has changed
        isPopularENUM('Yes','No')Flag saying whether the link is popular
        isValidatedENUM('Yes','No')Flag saying whether the link has been + validated
        RatingFLOATCurrent rating of link
        VotesSMALLINTTotal number of votes cast
        StatusSMALLINTStatus of link (HTTP Status code 200 => + OK, 404 => Not found, etc)
        Date_CheckedDATETIMELast time the link has been checked
        TimestmpTIMESTAMPTimestamp of last time link was modified.
        + +

        +   + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Category
        ColumnTypeNotes
        IDINTPrimary + Key, Auto Incremented integer
        NameCHAR(255)Name of + the category
        FatherIDINTID Number + of parent category, 0 for a root level category.
        Full_NameCHAR(255)A slash + (/) separated list of category name. i.e. if the category is named + Video Cards and is in Hardware which is in Computers, then Full_Name + would be Computers/Hardware/Video_Cards
        DescriptionTEXTOptional + description used in category listings.
        Meta_DescriptionTEXTOptional + meta description for generated HTML pages
        Meta_KeywordsTEXTOptional + meta keywords for generated HTML pages.
        HeaderTEXTOptional + category header
        FooterTEXTOptional + category footer
        Number_of_LinksINTTotal + count of all links in this category and subcategories
        Has_New_LinksENUM('Yes','No')Flag + telling whether there are any new links anywhere within this category.
        Has_Changed_LinksENUM('Yes','No')Flag + telling whether there are any changed links anywhere within this + category.
        Newest_LinkDATEThe date + of the most current link within this category tree.
        TimestmpTIMESTAMPAuto + generated timestamp of the last time this record was updated.
        Category_TemplateCHARContains the + name of a custom template to use, or template set to use when displaying a category.
        + +

        +   + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Users
        ColumnTypeNotes
        UsernameCHAR(50)Primary + key representing the users login name
        PasswordCHAR(25)Users + password (default is not encrypted)
        EmailCHAR(75)Email + address
        NameCHAR(75)Real Name
        ValidationCHAR(20)Optional + validation code that gets sent to users email to ensure its a real + email address.
        StatusENUM('Not + Validated', 'Registered','Administrator')Flag + saying what class of user this is.
        ReceiveMailENUM('Yes','No')Flag + saying whether the user should get any email or not.
        NewsletterENUM('Yes','No')Flag + saying whether the user is subscribed to the newsletter or not.
        + +

        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db_struct.gif b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db_struct.gif new file mode 100644 index 0000000..7b8619e Binary files /dev/null and b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_links_db_struct.gif differ diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_modperl.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_modperl.html new file mode 100644 index 0000000..08a8dbe --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_modperl.html @@ -0,0 +1,60 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Gossamer Links Developers Guide: + mod_perl Setup

        +

        mod_perl is, simply, integrating perl inside of the Apache web browser. Gossamer Links fully supports + mod_perl, and it is very easy to get started.

        +

        Add the following section to + your httpd.conf file:

        +
        <Location /url/to/links/cgi>
        +     SetHandler perl-script     
        +     PerlHandler Apache::Registry
        +     PerlSendHeader On
        +     Options +ExecCGI
        +</Location>
        +

        And to your perl startup + file you need to add:

        +
             use lib '/full/path/to/admin';
        +     use Links::mod_perl;
        +

        And you are done! Gossamer Links + will pre load all the modules needed, and also sets up a mod_perl handler + which can be used to increase performance for ceartain tasks. 

        +

        For more information on + mod_perl, please visit their home page at http://perl.apache.org.

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins.html new file mode 100644 index 0000000..8e298c0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins.html @@ -0,0 +1,107 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Gossamer Links Developers Guide + : Understanding Plugins

        +

        Plugins are a powerful new + feature of Gossamer Links that allows you to easily create, distribute and + install addons to Gossamer Links. Using the Plugin API you can easily override + any aspect of the program..

        + +

        At it's heart, a plugin is + simply a tar file with at least two files: Install.pm and Yourpluginname.pm. + The install file manages installation and removal code, and the other file + contains your main code. All plugin code must be under the name space + Plugins::Yourpluginname for them to work correctly. You can use the Plugin + Wizard to create a template file for you to start with.

        + +

        There are three main ways a + plugin interfaces with Gossamer Links:

        + +

        1. Plugin Hooks:
        +
        A hook is simply a label for a section of code in Gossamer Links. For example + the user_add_link hook is when a user adds a link to the database. There are + a number of predefined hooks that are available for you to add code to, or + replace existing code. Your plugin can register some code to run before or + after a specific hook and optionally cancel the main code that would have + run. 

        + +

        It works as follows. We'll + use the search_results hook as an example:

        + +
          +
        1. The user does a search + for the word 'alpha'. 
        2. +
        3. Gossamer Links figures out the + user is searching for something, and recognizes this is a plugin hook + spot. It loads the plugin config file, and checks to see if any plugins + are registered for the hook 'search_results'. If it doesn't find any, it + just runs the regular search and continues on. 
        4. +
        5. If it finds a plugin that + has registered a subroutine to run before the hook, it will run that + subroutine and capture the output. The subroutine must call GT::Plugins->action ( STOP ) + or GT::Plugins->action ( CONTINUE ); If it calls STOP, the main Gossamer Links code is + skipped, and we go to step 5. If it calls CONTINUE, any other plugins + are similarly processed.
        6. +
        7. The main code is run.
        8. +
        9. Gossamer Links now looks for a + plugin that has registered a subroutine to be run after the hook. It + runs all post subroutine hooks. If a subroutine calls STOP, then no + more hooks are run.
        10. +
        11. Code continues as normal.
        12. +
        +

        As you can see, there are a + lot of possibilities. If you want your search results to search AltaVista + automatically, you simply set up a POST search_results plugin that only runs + if the Gossamer Links code found no matches. If you want to setup a search cache, + you setup a PRE search_results hook that checks to see if it knows the + results that the user is looking for, and if so return immediately, don't + run any other plugins.

        + +

        2. Admin Menu Options:
        +
        Your plugin can create menu options in the Admin. When the install is + run, you can add any number of menu options that a user can click on.

        + +

        3. User Options:
        +
        The plugin interface includes a simple get/set interface to store user + options.

        + +

        For more information on + creating plugins, be sure to read the rest of the guide, and walk through + the examples.

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins_install.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins_install.html new file mode 100644 index 0000000..25ed3ab --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_plugins_install.html @@ -0,0 +1,139 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Gossamer Links Developers Guide + : The Install File

        +

        Each plugin must contain an + Install.pm file. This file contains install and uninstall code that the + plugin requires. The plugin wizard will create a useable Install.pm file for + you, but if you need to do anything special like creating SQL tables, + extracting files, or adding templates you will need to edit the Install.pm + file. The install file must contain four subroutines:

        + +

        sub pre_install {}
        +
        The pre install function displays a message to the user before the + plugin is installed. It should return a string containing HTML that will be + displayed. You can output an HTML form with form fields asking the user any + information you will need in the actual install.

        + +

        sub install { my ($mgr, + $tar) = @_; }
        +
        This function does the actual install of the plug in. Passed in are two + arguments, the first is a GT::Plugins::Installer object which you can use to + setup hooks, menu  options or user options (see the Plugin Wizard for a + sample). The second argument is a GT::Tar + object that has all the files in your current tar. You do not need to + extract the install.pm or Yourpluginname.pm file, that is done + automatically.

        + +

        Your function should return + an HTML message of the plugin results. If you want to abort the install, you + should return undef and have an error message stored in $Plugins::Yourpluginname::error. + You should always return a useful  error message if there was a problem + with the install.

        + +

        sub pre_uninstall {}
        +
        The pre uninstall function is the same as the pre_install function + described above. 

        + +

        sub uninstall { my $mgr = + shift; }
        +
        The uninstall function takes one argument, a GT::Plugins::Installer + object. You should be sure to clean up any columns you created, and drop any + tables you created.

        + +

        Examples
        + 1. Your install needs to add a custom column named 'Review' to the Links + Table to do this we will need a GT::SQL::Editor + object. However, we should first check to make sure the column doesn't + already exist (as they may be upgrading the plugin):

        + +
        unless (exists $DB->table('Links')->cols->{'Review'}) {
        +    my $editor = $DB->table ('Links');
        +    unless ($editor->add_col ( 'Review', { type => 'TEXT' }) {
        +        $Plugins::Pluginname::error = "Unable to add column to Links: $GT::SQL::error";
        +        return;
        +    }
        +}
        + +

        2. Your install needs to + create a new table called Reviews that has a username column that relates to + the Users table, and an ID column that relates to the Links table. For this + we will need a GT::SQL::Creator + object.

        + +
        my $creator = $DB->creatore ('Reviews');
        +$creator->cols ( {
        +                   LinkID => { pos => 1, type => 'INT', not_null => 1 },
        +                   ReviewedBy => { pos => 2, type => 'CHAR', size => 25, not_null => 1 },
        +                   Review => { pos => 3, type => 'TEXT' },
        +                   ReviewDate => { pos => 4, type => 'DATE' }
        +                });
        +unless ($creator->create) {
        +   $Plugins::Pluginname::error = "Unable to add Reviews table: $GT::SQL::error";
        +   return;
        +}
        + +

        3. Your install needs to + extract a user cgi script into the users cgi directory. For this we will use + the GT::Tar object.

        + +
        # Get the file from the tar file, $tar was passed into install.
        +my $file = $tar->get_file ('newscript.cgi');
        +# Get the entire code as a string.
        +my $code = $file->body_as_string;
        +# Replace the path to perl with the users perl.
        +$code =~ s/^#!(.*)/$CFG->{path_to_perl}/;
        +# Replace the use lib with the users admin directory.
        +$code =~ s/use lib '[^']+'/use lib '$CFG->{admin_root_path}'/;
        +$file->body ($code);
        +# Set the name of the file
        +$file->name ($CFG->{admin_root_path} . '/../newscript.cgi');
        +# Save it.
        +unless ($file->write) {
        +   $Plugins::Pluginname::error = "Unable to extract newscript.cgi file. Reason: $GT::Tar::error";
        +   return;
        +}
        +# Set permissions
        +chmod (0755, $file->name);
        + +

        Note: We have to make sure + to set the path to perl, chmod the file, and add a use lib to the admin + directory. All this information is available in the Gossamer Links configuration: + $CFG.

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_ref.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_ref.html new file mode 100644 index 0000000..d28c960 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_ref.html @@ -0,0 +1,55 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Links + SQL Developers Guide: Reference Overview

        +

        Gossamer Links is a complex program with many aspects. We have tried to + provide a complete reference to help you understand better how it works, and + more importantly how you can get it to work for you.

        +

        Included you will find:

        +

        Database Structure + - a complete overview of how the tables are linked together, and what the + fields are.

        +

        Core + Files and Variables - a guide to what the main Gossamer Links variables do, + and what each Links:: module is for.

        +

        GT + Module Documentation - set of documentation to the GT library of + modules.

        + +
        + + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_sample.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_sample.html new file mode 100644 index 0000000..dab8a37 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_guide_sample.html @@ -0,0 +1,495 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + + + +
        + +

        Links + SQL Developers Guide: + Sample Plugin

        +

        Sample Plugin - Search + Cache
        +
        In this sample, we will develop a sample plugin so you can see the full + process from Start to End. It's recommended you open a new browser window + with the plugin + wizard and follow along. The plugin wizard will create a template for + you to use to start your plugin.

        +

        We are going to add a search + cache to Gossamer Links, so that when a user searches the database, their results + will stay cached. The next time a search for the same term is done, the + results will be retrieved from cache without nearly the overhead.

        +

        Step 1: Naming your + plugin
        + You will be prompted to give your plugin a name. The name of your plugin + corresponds to the package space it will run under, so it must conform to + perls syntax. It should be only letters and numbers, and must not contain + spaces. Our sample plugin is called 'SearchCache'. Convention dictates that + you start with a capital letter. All code will run under the package + Plugins::SearchCache. Enter in SearchCache in the name of the plugin and hit + Create.

        +
        +
        + + + + + +
        Create + new plugin named: +
        + + +
        +
        +
        +
        + +

        Step 2: Meta Information
        + The next step is to edit meta information about your plugin. This + contains information about your plugin that will be used by Gossamer Links when + users install it. You must enter at a minimum a Version Number, but should + fill out all the fields completely.

        +

        It's very important to + update the version number when you make changes. When users download plugins, + they are presented with the version number, and from that can decide if they + want to upgrade an existing installation.

        +

        To start, we'll enter:

        +
        +
        +
        + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Version: +

        +
        Author:
        URL:
        License:
        Links + SQL Version Required:
        Description:
        +
        +
        +
        +
        +

        and hit next. This information +will now be saved with your plugin.

        +

        Step3: Hooking into Links + SQL
        + Next we need to hook into Gossamer Links. We need to interact with Gossamer Links's + search engine. There are a lot of hooks in Gossamer Links, and the plugin system + gives you access to any of them. You can tell Gossamer Links to run your code + before or after the normal function, and it can override the existing + functions.

        +

        We decide that we will need + two hooks. One before the search, and one after the search. The one before + the search will look at what the user is searching for, and if it's in the cache, the plugin will return those results, and tell Gossamer Links it doesn't + need to do the search. If it's not in the cache, it will tell Gossamer Links to + continue on. 

        +

        We also need a hook after + the search, and if our cache wasn't used, let's save the results. On the + hooks screen, you need the name of the hook, whether it's a pre or post + hook, and what function to run. Remember, your function must be in the + package Plugins::SearchCache::. In this case, I named the pre one + query_cached, and the post one, log_query. You will need to add it in + twice. Once done it should look like:

        +
        +
        + + + + + + + + + + + + + + + + +
        HookTypeCode
        + search_resultsPREPlugins::SearchCache::query_cached
        + search_resultsPOSTPlugins::SearchCache::log_query
        +
        +
        +

        Step 4: Admin Menu
        +
        We don't have an admin menu for this plugin, so we will skip this step. This +would normally provide the plugin author to give the user a link in the admin +screen for any admin functions that are required.

        +

        Step 5: User Options 
        +User options are variables you can have the plugin user fill out and access in +your plugin. We won't do any for this, but maybe for the next version we will +add a user option for how long the cache should last.

        +

        Step 6: Included Files
        +
        Every plugin needs at least an Install.pm and a ModuleName.pm (in our case +SearchCache.pm). The plugin wizard will automatically generate these two files +for you. It is quite common to need to bundle other files though, from images, +to user cgi. From here you can upload those files that you need and the plugin +wizard will bundle it in your plugin and create the install function for you.

        +

        We don't need any extra files +for the SearchCache, so we hit next.

        +

        Step 7: Install Messages
        +
        The last step is too add an install and uninstall message. This should +explain to the user what the plugin will do exactly during the install and +uninstall: i.e. what tables it will create, what files it will install, +etc. 

        +

        We also need to add any custom +install and uninstall code. The Wizard takes care of hooking into Gossamer Links, but +we need to provide code to create our SearchCache table, and to remove the +SearchCache table when we are done. Fill in the form with the following +information:

        +
        + +
        +
        + + + + + + + + + + + + + + + + + +
        Install + Message
        UnInstall + Message
        Install + Code
        Uninstall + Message
        +
        +
        +

        You are now all done! Hit + Next and the plugin wizard will create the plugin template for you. It has + automatically generated an Install.pm file and a SearchCache.pm file for + you. The Install file should be pretty much complete, so all you have left + to do is edit the SearchCache.pm file.

        +

        Click on the Plugin Editor + to finish the job!

        +

        Step 9: Insert your + code
        +
        Now you should see a screen that looks something like:

        +
        +
        + + + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Plugin + Details
        Plugin:SearchCache
        Version:0.01
        Author:Alex + Krohn
        License:Freeware
        Description:This + plugin will cache search results and speed up searches + on similiar topics.
         
        Plugin + Files
        Install.pm + (3366 bytes)Edit + | Perl Check
        SearchCache.pm + (507 bytes)Edit + | Perl Check
        +
        +
        +
        +

        Now we need to add our + code for the Search Caching. Click on Edit for SearchCache.pm and enter:

        +

        +
        +

        Simply cut and paste the + above code into the edit box, and hit update. To make sure everything is + correct, you can click on Perl Check to run a syntax check on it. Try it and + you should see + 'SearchCache.pm syntax ok'.

        +

        A couple things to note about + the code:

        + + + + + + + + + + + + + + + + + + + + + + + + + +
        +
        package Plugins::SearchCache;
        +
        Don't forget to put + your code inside the proper package or it will never work.
        use strict; 
        +
        Always, always run your + plugins under use strict. If you want your plugin to be mod_perl + compatible, this will be essential.
        +
        use Links qw/$IN $DB $CFG/;
        +
        This makes available + several variables that will be useful to you. $IN is a GT::CGI object + that has the form input, $DB is a GT::SQL object that will let you + interact with the database and $CFG is the Gossamer Links configuration + (note you shouldn't change anything here). Other variables that you + can ask for include $USER which is the currently logged in user (a + hash of the user record).
        +
        use GT::Dumper;
        +
        This module lets you + dump the contents of a perl data structure into a string. We use it to + dump the current search results to a string, and then save that string + to the database.
        +
        use GT::Plugins qw/STOP CONTINUE/
        +
        This imports two + constants STOP and CONTINUE. You signal the plugin manager to STOP + running the existing code, or by default it will continue. You do this + by calling GT::Plugins->action ( STOP );
        + 1; + Don't forget, all + module must end with a 1; or they won't be able to get require'd in + properly.
        +

        The important thing to +understand is how arguments are passed:

        +

        PRE Hooks: The arguments you +receive are the same arguments the main code would receive. So if your hook was +site_html_link (the function that displays a link), your arguments is a single +hash reference of the link to display. Your hook needs to return that same +argument if are continuing. If you are STOP'ing and don't want any other code to +run, you should return the same thing the main code would return. For +site_html_link, that would be a parsed template.

        +

        POST Hooks: Very similiar. + Your input is the output of the main code, and you should return the same + type of arguments. So for search_results, you get a hash reference of + template tags, you need to make sure you return a hash reference as well.

        +

        To signal that you want to + stop, your plugin code should run:

        +
        +

        GT::Plugins->action ( + STOP );

        +
        +

        This tells the plugin + manager not to run any more hooks, or the main code. However, you still need + to make sure you return the proper arguments.

        +

        Step 10: All Done, try it +out!
        +
        Now, we are all done! Click on Plugin Manager and it should be listed as +a plugin waiting to be installed. Click on Install and you should now be able to +try it out!

        +

        However the SearchCache is + just a very simple cache, there are still quite a few things we could do to + make it better:

        +

        1. Cache the page number with +the results. Right +now it's broken as if you search for page 2, you will get the cached page 1. We +could fix this by appending the page number requested in the keyword field.

        +

        2. Remove entries from the +cache. We will want to remove old entries from the cache. This should be done +periodically to make sure that cached data isn't too out of date.

        +

        3. Use GT::Cache to cache +in-memory if under mod_perl. This would be an even better performance boost as +no database access would be required to return matching results. GT::Cache would +also limit the cache size automatically and keep the most popular ones, while +removing the less frequent ones.

        +

        Maybe for version 0.02?

        +

        This just scratches the + surface of what you can do, please visit the reference + section, or join + other plugin developers + online for more information.

        + +
        + + + + + +
        +Table +of Contents +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_payments.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_payments.html new file mode 100644 index 0000000..f64c15e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_payments.html @@ -0,0 +1,111 @@ + + + + +Gossamer Links Help: Payments + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Payments Help

        +

        The Payments menu allows you to configure your Gossamer Links installation to accept payments from your users for listing their links for defined periods of time. Paid links will be displayed above unpaid links in your directory. Three different types of payment terms can be created: display terms, in which users pay for a link to be displayed for a set period of time, renewal terms, which allow users to renew their listings after making an initial display payment, and recurring terms, which will automatically charge users at set intervals. Discounts can also be created, giving users reduced costs on listings after they have listed a set number of links ("buy two, get the third 50% off"). Payments can be accepted by configuring payment methods: currently, methods can be configured for PayPal, Moneris, Authorize.net, 2CheckOut and Worldpay accounts. Logs of all payments are stored and can be viewed from the Payments menu. + +

        +

        Payment Setup
        The Payment Setup menu is your primary tool for managing Gossamer Links payments. From this menu payments can be enabled and disabled, and payment levels can be configured.
        + +

        +
          +
        • Choose whether or not to enable payments.
        • +
        • Set when to send a renewal notice to users whose links are almost expired in the "Expiry Notify" field. The notice will be sent the number of days you enter before expiry. You will also have to set up a cron job. From shell, type:

          crontab -e

          and adding the following line (if it doesn't already exist from a previous installation), and save it:

          0 2 * * * /full/path/to/admin/cron/expiry_notify.pl

        • +
        • Choose whether payments should by default be optional, required, or not accepted for new links. Note that this option only defines the global directory payment settings; individual categories within your directory can be configured separately.
        • +
        • Choose whether or not all links that have been paid for will automatically be validated, or whether to have them manually validated by admins and editors.
        • +
        • You can enter a brief description of your payment system that will appear above the list of payment options users can choose from. This page will be shown when users try to add a link in a category that requires or offers payments.
        • +
        • Existing default payment terms that you have configured for your installation will be listed, with the cost and duration of the term displayed. These terms are organized into display, renewal and recurring terms. Any of these existing terms can be deleted by checking the "Delete" box beside the desired term(s) and clicking the "Save Changes" button.
        • +
        • New payment terms can also be configured from this menu. Enter a payment cost, choose what type of payment term you wish to create (single, renewal, recurring), and duration of the payment (enter a numeral in the field and choose a period of time from the drop-down menu).
        • +
        • Existing payment discounts that you have configured for your installation will be listed, with the number of links at which users will begin to receive the discount, the percentage that will be deducted from payment costs, and any description you've defined for that discount.
        • +
        • New discounts can also be configured from this menu. Enter the number of links at which the user will begin to receive the discount. This is inclusive, so a discount with 4 entered in the number of links means that the user will receive the discount when they go to pay for their fourth link. Enter a percentage for the discount; this percentage will apply to single and recurring payments only. You can enter a custom description for the discount that will appear when the user is selecting a payment term. If you do not enter a description, the default description will be displayed: "Payment costs have been discounted by X% for this link."
        • +
        • Click the "Save Changes" button to confirm your changes.
        • + +
        +

        Payment Methods
        The menus listed under "Payment Methods" allow you to configure all options regarding how payments made by your users will be processed. Payment methods can currently be configured for PayPal, Moneris, Authorize.net, 2CheckOut and Worldpay accounts. The following information will help you configure your accounts to best suit receiving payments through Gossamer Links.
        + +

        +
          +
        • PayPal: It is required that you configure your "Instant Payment Notification Preferences", found in your Account Profile on the PayPal website. Enter the location of your postback.cgi in the field provided and check the IPN box. If you are using multiple IPN-aware applications, you should enter the URL to the postback.cgi (as defined in the db_cgi_url option in the "Paths and URLs" section of the Setup menu) in the "Payment IPN URL" field while setting up PayPal to override the default URL. +
        • +
        • Moneris: +You will need to generate an account token. +
        • +
        • Authorize.net: You will need to generate a Transaction Key. Click on "Obtain Transaction Key" in the Settings menu. This key will be required when configuring your Authorize.net settings in Gossamer Links. +
        • +
        • 2CheckOut: You should configure the settings in the "cartpurchase.2c Passback Parameters" section of the "Return" menu (found under the "Account Details" heading). Set the "Return to a routine on your site after credit card processed?" option to "Yes". Provide the URL of your postback.cgi (as defined in the db_cgi_url option in the "Paths and URLs" section of the Setup menu). If you are accepting cheques through your 2CheckOut account, set the "Return to a routine on your site after a check is processed?" option to "Yes". Define a "Secret Word" in the Overall Passback Parameters section (just below the "cartpurchase.2c" section). +
        • +
        • WorldPay: In your Installation Configuration menu, you should set the "Callback URL" field to contain your postback.cgi (as defined in the db_cgi_url option in the "Paths and URLs" section of the Setup menu). The "Callback enabled" checkbox must be checked. The "FuturePay callback Enabled" checkbox must be checked if you are going to be using your WorldPay account for recurring payments. If the "Use callback response" checkbox is checked, the user will be shown the worldpay_receipt.html template on WorldPay's site upon completion of a payment. If the checkbox is not checked, WorldPay will direct the user elsewhere upon completion of a payment (this location can be defined in the Payment Page Editor section. +
        • +
        +

        Adding Methods Payment methods can be either direct or remote. Direct payment methods store users' payment information on your SSL-enabled site, allowing you to customize the appearance of the page where payment information (such as credit card numbers) will be transferred. Be sure to define the location of your SSL page in the db_cgi_url_https option in the "Paths and URLs" section of the Setup menu if you add any direct payment methods. Remote payment methods allow you to process payments if you do not have an SSL-enabled site. Remote method payments are handled on the payment provider's website (https://www.paypal.com, for example). Users will be able to configure their payment from your site, but they will have to actually confirm the payment on the remote site, which you will not be able to customize. See below for details on configuration options for specific methods. + +

        +
          +
        • PayPal: You will need to enter the email address used on your PayPal account. Choose the currency in which payments will be processed. If you do not define a currency here, the currency selected in your Moneris account configuration will be used. Choose the buttons that users will click on to make signup payments or donations. Choose from the default buttons provided, or provide an https:// URL of another desired image. You can specify an image (such as a company or site logo) that will appear on the PayPal page users make payments on in the "Image URL" field. If you are using multiple IPN-aware applications (such as running Gossamer Links and Gossamer Forum simultaneously), you should enter the Gossamer Links postback.cgi (as defined in the db_cgi_url option in the "Paths and URLs" section of the Setup menu) in the "Payment IPN URL" field to override the default URL. If you want users to be able to include comments or other text with their payments; enter a title for a text field that will appear on the PayPal payments page. If you do not provide a title, no text field will be provided. Choose a background colour for the PayPal payments page. If you want a PayPal account other than your primary one to receive the actual payments made by users, enter that address in the "PayPal Recipient E-Mail" field. + +
        • +
        • Moneris: You will need to enter the account token generated from your Moneris account, as well as the eSelect Store ID for your account. You can enable a test mode which allows you to test your direct payment support. When the test mode is enabled, live credit card transactions cannot be processed. You will need to change your account token and store ID as well as use a special credit card number for testing. For more information, refer to this document on the Moneris site. + + +
        • + +
        • Authorize.net: You will need to provide your Login ID and the Transaction Key generated from your Authorize.net account. You can choose which currency payments will be processed in. If you do not define a currency here, the currency selected in your Authorize.net account configuration will be used. You can configure your Authorize.net password. It is recommended that you do not enter any value in this field unless you are unable to obtain a transaction key. Entering a password here is strongly discouraged. You can specify a "Merchant Confirmation Email", which will receive payment information in addition to the address configured in your Merchant account. You can choose whether or not users will receive email from Authorize.net informing them of their payments. You can toggle Test Mode on and off. Test mode allows you to ensure that payments via Authorize.net are functional without actually processing payments. + + + + +
        • + +
        • 2CheckOut: You will have to provide your 2CheckOut Seller ID as well as your 2CheckOut Secret Word. + + + + +
        • + +
        • WorldPay: You will have to provide your WorldPay Installation ID and password. You will have to provide the MD5 password used by your WorldPay account to verify orders. You can choose the currency in which payments will be processed. If you do not define a currency here, the currency selected in your Authorize.net account configuration will be used. You can toggle Test Mode on and off. If you choose to enable Test Mode, you will be able to either have WorldPay approve or decline your credit card. Test Mode will still catch any errors in payments, regardless of which option you choose.
        + +

        Payment Logs
        The payment logs allow you to review all payments that Gossamer Links has processed. Details of the payment or the user who made the payment can be viewed.
        + +

        Payment Details
        You can use the "Payment Details" field to search for a specific payment record by ID. Simply enter the ID of the payment you wish to view and click "Go". The payment's detail record will be displayed in full, just as if you were viewing it in the logs.
        + + + + + + +

        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugin_ref.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugin_ref.html new file mode 100644 index 0000000..dd749cd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugin_ref.html @@ -0,0 +1,378 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Developers Guide
        +
        Overview | Managing + Plugins | Links + SQL Developers Guide : Plugin Hooks

        +

        This + section describes all the hooks available in Gossamer Links.

        +

        Searching 

        +

        Adding

        +

        Modifying

        + +

        ...

        + +
        + +

        Searching

        + + + + + + + + + + + + + + + + + + + + + +
        Name:search_results
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for search_results.html template.
        + On failure: tags required for search_failure.html + template. +
        Triggered + On:search.cgi + being run with query=something being passed in.
        Description:This hook + is run whenever a search is run, and it generates a list of search + results that will be sent to the success or failure templates + depending on whether error => 'message' is a key in the hash that + is returned.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_search_results
        PRE + Input:HASH REF:
        +   link_results => html formatted list of matching links,
        +   category_results => html formatted list of matching links,
        +   link_hits => total number of links matched
        +   cat_hits => total number of categories matched
        +   next => a formatted html toolbar or empty if not that many + results
        +   term => a url escaped version of what the user searched for
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:search.cgi + being run with some results being found. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_search_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why no results + were found
        +   term => a url escaped version of what the user searched for
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:search.cgi + being run with no  results being found. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + +

        Adding Links

        + + + + + + + + + + + + + + + + + + + + + +
        Name:user_add_link
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for add_success.html template.
        + On failure: tags required for add_failure.html + template. +
        Triggered + On:add.cgi + being run with add=something being passed in.
        Description:This hook + is run whenever the add_form is submitted, and it adds a link to the + Links table, and emails the administrator that a link is awaiting + validation. If you want to hook into whenever a link is added, from + the admin, or from the user side, see add_link
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_add_success
        PRE + Input:HASH REF:
        +   A complete hash ref of the new link that was added which + includes all columns defined in the Links table, plus:
        +   Category => a newline separted string of Category Names that + this link was added too.
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:add.cgi + being run and the link being successfully added.
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_add_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why link could + not be added
        +   Category => a select list/hidden field for use in category + form.
        POST + Input:SCALAR: + Fully formatted HTML page showing search results.
        Triggered + On:add.cgi + being run, with errors in the submission. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + +

        Modifying Links

        + +

        + + + + + + + + + + + + + + + + + + + + + +
        Name:user_modify_link
        PRE + Input:none
        POST + Input:HASH REF:
        + On success: tags required for modify_success.html template.
        + On failure: tags required for modify_failure.html + template. +
        Triggered + On:modify.cgi + being run with modify=something being passed in.
        Description:This hook + is run whenever the modify_form is submitted, and it either changes a + link in the Links table, or records the change awaiting validation.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_modify_success
        PRE + Input:HASH REF:
        +   A complete hash ref of the new link that was changed which + includes all columns defined in the Links table, plus:
        +   Category => a newline separted string of Category Names that + this link was placed in.
        POST + Input:SCALAR: + Fully formatted HTML page.
        Triggered + On:modify.cgi + being run and the link being successfully changed.
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + + + + + + + + + + + + + + + + + +
        Name:site_html_modify_failure
        PRE + Input:HASH REF:
        +   error => formatted error message string of why link could + not be added
        +   Category => a select list/hidden field for use in category + form.
        POST + Input:SCALAR: + Fully formatted HTML page showing search results.
        Triggered + On:modify.cgi + being run, with errors in the submission. 
        Description:This hook + generates a fully formatted html page.
        + +

        Top

        + + + + + +
        +Table +of Contents +
        + + + + + +
        +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugins.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugins.html new file mode 100644 index 0000000..af2f91b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_plugins.html @@ -0,0 +1,120 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        PlugIn Help
        + Warning:
        Plugins + contain code that will get executed on your system. You should be careful + before installing any plugins from a source that you do not trust! 

        +

        Your plugin management screen is +divided into three options:

        +
          +
        • Plugin Manager - This lets you +install, uninstall, edit and delete plugins from Gossamer Links
        • +
        • Plugin Download - This lets + you fetch plugins from Gossamer Threads, remote URL's, or from your own + computer.
        • +
        • Plugin Wizard - This helps + you create your own plugin! If you are interested in learning more about + creating your own plugins, please check out the Links + SQL Developers Guide for more information.
        • +
        +

        This page will go over how + to manage your plugins, download new ones, and install and remove existing + ones.

        +

        The Plugin Manager:
        +
        The plugin manager lets you + install, remove or edit plugins. The opening screen contains:

        +
          +
        • A list of plugins already + installed on your system. It will show you the plugin name, plugin author, + and version number, and offer you the choice of removing the plugin or + editing it.
        • +
        • A list of plugins + available to be installed. Again, the plugin name, plugin author and version + number are shown, as well as links to install the plugin or remove it from + your system. 
        • +
        +

        Installing Plugins
        +
        To install a plugin, simply click on Install beside the plugin + you want to add. A screen will be displayed confirming that you want to add + the plugin and display any special instructions from the plugin author. You + can then confirm the install, or abort and return to the main screen. Upon + confirming the install, the plugin will be installed, and will show up on + your list of installed plugins. Also, a menu will appear on the left showing + any special functions the plugin provides. 

        +

        Removing Plugins
        +
        Removing plugins is just as simple. Simply click Uninstall beside + the plugin and you will be prompted with a confirmation screen displaying + any special message from the plugin author. You can then click Full + Uninstall, or Skip Plugin Uninstall. You would want to skip the plugin + uninstall if you don't want to lose any data the plugin created. For + instance, the SearchLogger plugin stores keywords users have searched on. If + you didn't want to lose this data, you would click Skip Plugin Uninstall. + Typically, a Full Uninstall is recommended.

        +

        Upgrading Plugins
        +
        Plugins get improved all the time, and upgrading is a snap. When you + install a plugin, if it is already on your system, you will be prompted if + you want to overwrite it or not with the newer version. Simply click + overwrite, and the plugin will get upgraded.

        +

        Editing Plugins
        +
        You can edit your installed plugins. Simply click on Edit beside the + plugin you want to edit. This lets you temporairly disable a plugin hook, + while you are testing, or remove menu choices you don't use, as well as set + plugin options.

        +

        Removing Plugins
        +
        If you are tired of a plugin and don't plan to use it again, you can + remove it from your Uninstalled list. This actually removes the file, and is + not recoverable. Be sure you are done with the plugin before removing it.

        +

        Plugin Download:
        +
        There are three ways to add new plugins.

        +

        1. View a list of plugins on + Gossamer Threads. Clicking here will show you a list of plugins available + for download from Gossamer Threads. You can just pick which one you want and + it will automatically download it to your computer. Then simply click on + Install and it will be activated.

        +

        2. You can enter in a URL to + a plugin, and Gossamer Links will fetch the plugin and save it to your computer.

        +

        3. You can upload a plugin + file, and Gossamer Links will save it to your computer.

        +

        Once the plugin has been + retrieved, it shows up in the Uninstalled list. Simply click Install and it + will be added to the list.

        +

        That's all there is to it! + Interested in expanding Gossamer Links? Be sure to read the + Gossamer Links Developers Guide!

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_support.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_support.html new file mode 100644 index 0000000..9be8764 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_support.html @@ -0,0 +1,51 @@ + + + + +Gossamer Links Help: Plug Ins + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Support Options

        +

        Having problems with Links + SQL or have a question that you need answered?

        +

        Search the support forum:

        +

        http://www.gossamer-threads.com/perl/gforum/gforum.cgi

        + and the resource center: +
        +

        http://www.gossamer-threads.com/scripts/resources/

        + If you still can't find the answers you're looking for, please fill out a support ticket: +
        +

        http://www.gossamer-threads.com/scripts/support

        +
        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates.html new file mode 100644 index 0000000..ccb32c4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates.html @@ -0,0 +1,98 @@ + + + + +Gossamer Links Help: Admin + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Template Help

        + +

        Gossamer Links is powered entirely by +templates. Any part of the output you want to change can easily be altered by +editing one of the templates.

        + +

        Template Sets:
        +
        You can have as many template sets as you need. You can use +multiple template sets to provide multi-language versions of your directory, or +to brand your directory in a different look.

        + +

        If you are using Dynamic pages, +you can view your templates by simply going to page.cgi?t=luna where +luna is the name of the template set you want to use. So you could +create a link page.cgi?t=english and page.cgi?t=french to provide two different +language versions for your visitors.

        + +

        You can set what template is +used by default, and when building html pages in Setup-> Build Options.

        + +

        Template Structure:
        +
        Gossamer Links template sets are laid out as follows:
        +

        +admin/templates/
        +                luna/
        +                        local/
        +                        compiled/
        +                ..
        +
        +

        luna is called the +template set, and inside the template set directory are the original templates that ship with +Gossamer Links. If you wish to make changes to a template manually (using FTP, or the included FileMan), +you must save your altered template inside the local directory. The way it works is that +Gossamer Links will look for your template first in the local directory, then inside the main template +set directory. So if you only change the header and footer, all you do is save include_header.html +and include_footer.html inside the local directory.

        + +When you upgrade, Gossamer Links will overwrite all files in the luna directory, so you must put your +changes inside local. If you use the template editor included in Gossamer Links, it will do this for you.

        + +The compiled directory is where Gossamer Links converts your template to code for faster execution. You +should not need to touch any files in this folder. + +

        Templates:
        +
        Gossamer Links has quite a few templates. You can think of each +"screen" being equal to one template. So when a user clicks on add and +sees an add form, that screen is represented by one template (conveniently named +add.html). Similarly, the search results are represented by a template +search_results.html. this file by hand, but rather use the admin interface. +A complete list of the templates used in Gossamer Links can be found under +"Templates" in the "Customizing Gossamer Links" section of the manual.
        + + +

        For help on editing templates, be sure to read our +Template Syntax section. For +tags you can use on the templates, be sure to read the +Template Tags section. For in-depth +information about the template system, see the +Template Documentation. +

        +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_syntax.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_syntax.html new file mode 100644 index 0000000..ed39ad8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_syntax.html @@ -0,0 +1,126 @@ + + + + +Gossamer Links Help: Admin + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Template +Syntax

        +

        Gossamer Links template engine is +powered by our GT::Template +module. For a complete list of all the functionality available by this module, +be sure to read it's documentation.

        +

        Gossamer Links provides a very +straight forward way of templates. If you are familiar with ASP or PHP, then +this should be no problem. Simply, each template has a set of tags on it that +get replaced with HTML when the page is displayed. So for example, on the home +page (home.html template), there is a <%category%> tag. This tag +will be replaced with a full list of all the top level categories by Gossamer Links.

        +

        Tags:
        +
        Any tag in Gossamer Links always starts with a <% and ends with %>. +Everything in between will be replaced. White space does not matter, so:

        +
        1: <%category%>
        +2: <%       category         %>
        +3: <%
        +        category
        +%>
        +

        will all do the same +thing. 

        +

        Variables:
        +
        By default anything inside of a <% .. %> tag is considered a variable, +and will just be replaced with it's value. In the search results template +(search_results.html), <%link_results%> gets replaced with a list of +matching links, and <%category_results%> gets replaced with a list of +matching categories.

        +

        Template Comments:
        +
        Anything inside <%-- and --%> is considered a comment +and the template parser will remove these (so even if the user views source, +they will not be visible). The default templates use comments to let you know +what special tags are available on that template.

        +

        When Variables are not +Enough:
        +
        Quite often you need a bit more control on the layout. For instance, say you +want to display something different if no matching category results were found. +For this, you can use if, else, and elsif. It's pretty +straightforward:

        +
        <%if category_results%>
        +   <table>
        +     <tr><td>Here are your category matches: <%category_results%></td></tr>
        +   </table>
        +<%else%>
        +   Sorry, but no matching categories were found!
        +<%endif%>
        +

        Each if statement must +end with a matching endif statement. Here's another example on the add +form. If the user submitted the form and there was an error, we need to display +that error to the user:

        +
        <%if error%>
        +   <p><font color="red">Oops, there was a problem with your submission:
        +         <%error%>
        +   </font></p>
        +<%endif%>
        +

        That html between the if +and endif tags will only get displayed if there was an error on the +addition. Also available are <%ifnot ..%> and <%unless +..%>

        +

        Loops:
        +
        If you are feeling a bit overwhelmed, then you can skip this part. Loops are +an advanced feature that provide complete control over the layout of the +directory. Perhaps you don't like the fact that the same link.html template is +used when displaying a list of search results and for displaying the links in +the category page. Well, by default Gossamer Links only provides you with a <%link_results%> +tag, so there is not much you can do, right? Wrong! For all of the major tags, +you can use loops instead. Let's look at search results. Instead of:

        +
        <p>Here are your matching links:<br><br><%link_results%></p>
        +

        You could do:

        +
        <p>Here are your matching links:<br><br>
        +<%loop link_results_loop%>
        +    <a href="<%URL%>"><%Title%></a>: <%Hits%>
        +<%endloop%>
        +

        So inside the <%loop%> +and <%endloop%> tag you have a series of links, and you can use any +link attribute you like. However, don't forget you can also use includes, so you +could do:

        +
        <p>Here are your matching links:<br><br>
        +<%loop link_results_loop%>
        +    <tr><td><%include link.html%></td></tr>
        +<%endloop%>
        +

        Now link.html will be loaded and +parsed!

        +

        Much More:
        +
        Be sure to read our GT::Template +docs for even more things you can do like math operations, function calls, and +much more!

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_tags.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_tags.html new file mode 100644 index 0000000..0f66ca4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_templates_tags.html @@ -0,0 +1,59 @@ + + + + +Gossamer Links Help: Admin + + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        Template +Tags

        +

        A common question we get is what +tags are available on each template. In the default template set, each template +has a comment listing what tags are unique to that template. However, there are +many more tags available.

        +

        Seeing tags available:
        +
        To see what tags are available on a page, you can put <%GT::Template::dump%> +anywhere in your template, and when it is parsed, that will get replaced with a +nice html table of the tag name and the current value. If you use this, and the +page.cgi (dynamic view) it makes building your site very easy.

        +

        Global Tags:
        +
        Every template has all the tags defined in Build->Template Globals +available. Also available on all templates is all the User properties of the +currently logged in user. So you could add:

        +
        <%if Username%>
        +   Welcome <%Name%>!
        +<%endif%>
        +

        As the Username variable is only +available if there is a logged in user.

        + +
        + + + + +
        +Table +of Contents +
        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_toc.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_toc.html new file mode 100644 index 0000000..6d96ce5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/help_toc.html @@ -0,0 +1,89 @@ + + +Gossamer Links Help - Table of Contents + + + +

        Gossamer Links Help

        + + + + + +
        +
        +Table +of Contents +
        + + + +
        +

        TABLE OF CONTENTS

        + +

        + Your Admin +

        +

        Browse +

        Database +

        Build +

        Email +

        Plugins +

        Payments +

        Editors +

        +

        Templates +

        +

        Template + Syntax +

        Template + Tags +

        +

        Developers Guide

        +
        +

        Enhancing + Gossamer Links Easily

        +

        Understanding Plugins

        +
        +

        The + Install File

        +

        Plugin + Hooks

        +

        Sample + Plugin: Search Cache

        +
        +
        +

        More Samples to Come ...

        +
        +

        Reference + Overview

        + +
        +

        Database Structure

        +

        Core + Files and Variables

        +

        GT + Module Documentation

        +
        +

        mod_perl Setup

        +
        +

        Support + Options + +

        + + + + + + + +
        +Table +of Contents +
        +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index.html new file mode 100644 index 0000000..958af27 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index.html @@ -0,0 +1,15 @@ + + + Gossamer Threads Module Library Reference + + + + + <body bgcolor="#FFFFFF"> + + <p>Non frame capabale browser please view the <a href="admin.cgi?do=help&topic=/index_nav.html">index</a>.</p> + + </body> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index_nav.html new file mode 100644 index 0000000..9f1b6e1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help/index_nav.html @@ -0,0 +1,264 @@ + + + Gossamer Threads Module Library Reference + + + + + + + + +

        Module Index

        +

        GT

          AutoLoader

          Base

          CGI

          Cache

          Config

          Date

          Delay

          Dumper

          File

            Diff

            Tools

          IPC

            Filter

              Block

              Line

              Stream

            Run

          IPCountry

          Image

            Security

            Size

          Installer

          JSON

            PP

            PP5005

            PP56

            PP58

              Boolean

          Lock

          MD5

            Crypt

          MIMETypes

          Mail

            BulkMail

            Editor

            Encoder

            POP3

            Parse

            Parts

            Send

          Payment

            Remote

              2CheckOut

              PayPal

              WorldPay

          Plugins

            Installer

          SQL

            Admin

            Condition

            Creator

            Editor

            File

            Relation

            Search

            Table

            Tree

              Rebuild

            Types

          Session

            File

            TempTable

          Socket

            Client

          Tar

          TempFile

          Template

            Editor

            Inheritance

            Tutorial

            Vars

          URI

            HTTP

            HTTPS

          WWW

            http

              Header

              Response

            https

        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_body.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_body.html new file mode 100644 index 0000000..059945f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_body.html @@ -0,0 +1,14 @@ + + + +Gossamer Links - Help + + + + + +

        Help!

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_nav.html new file mode 100644 index 0000000..be0ca1a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/help_nav.html @@ -0,0 +1,16 @@ + + + +Gossamer Links - Help - Nav + + + + + +

        Help TOC

        + +

         

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home.html new file mode 100644 index 0000000..05c566d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home.html @@ -0,0 +1,19 @@ +<%Links::Config::load_vars%> + + +Gossamer Links <%cfg_version%> Administration + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires you to use a frames enabled browser..</p> + + </body> + + + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_body.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_body.html new file mode 100644 index 0000000..bf98f8f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_body.html @@ -0,0 +1,19 @@ +<%Links::Config::load_vars%> + + +Gossamer Links <%cfg_version%> Administration + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires you to use a frames enabled browser..</p> + + </body> + + + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_left.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_left.html new file mode 100644 index 0000000..6525215 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_left.html @@ -0,0 +1,69 @@ +<%Links::Tools::quick_links%> + + +Gossamer Links Administration Panel + + + + + +
        + + + + + + + + + + + +
         Quick Links +<%if manage%> +  done +<%endif%> +<%ifnot manage%> +  manage +<%endif%> +
        +<%if quick_links%> +

        +<%quick_links%> +

        +<%endif%> +<%if manage%> + + + + + + + + + + + + + +<%if quick_links%> + + + + +<%endif%> +
         Name:
         URL:
         Add:
         Remove:
        +<%endif%> +

         

        +
         Useful Links
        +
      • Gossamer + Threads
      • +
      • Support + Forum
      • +
      • FAQ
      • +

         

        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_nav.html new file mode 100644 index 0000000..2717111 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_nav.html @@ -0,0 +1,68 @@ +<%Links::Config::load_vars%> + + +Gossamer Links <%cfg_version%> Administration + + + + + + + + + + + + + + +
        Gossamer Links + AdminVersion: + <%cfg_version%>
        +  Home | + Browse | + Database | + Build | + Email | + Plugins | + Payments | + Setup | + Updates | + Static | + Dynamic + +

        Help

        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_right.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_right.html new file mode 100644 index 0000000..e7c8101 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/home_right.html @@ -0,0 +1,62 @@ + + +Gossamer Links Administration Panel + + + + + + + + +
        + +

        Gossamer Links Administration Panel

        +
        + +<%ifnot Links::Tools::remote_user%> +

        Warning: It appears +that the admin directory has not yet been password protected. If you are on an Apache server, you can do +it directly from the admin, otherwise you should +contact your ISP to protect this directory.

        +<%endif%> + +

        Thank you +for choosing Gossamer Threads, Inc. and our Gossamer Links script.

        + +

        This is +your Admin Panel.  It gives you full control over every aspect of your Links database.  +All the functions of this program are accessible through the Main Menu +that you see above.  Within each Main Menu option are sub-features for which we have written relevant Help +tutorials to help guide you through Gossamer Links. Just click on the Help link you see on the top right hand corner of the screen.

        + +

        On your left in the Quick Links +box, you can add frequently used url's in the admin, by simply cutting and +pasting the URL into the URL box, giving it a name, and pressing Add.

        + +

        In the Useful Links box, you +will find several links to Gossamer Threads that will help you out if you are +stuck.

        + +

         

        + +<%if config.updates_check_on_home and config.reg_number%> +<%include include_update_checker.html%> +<%endif%> +
        +

         

        + + + + + + + + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_header.html new file mode 100644 index 0000000..80e2eed --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_header.html @@ -0,0 +1,18 @@ +<%-- + Before including this template, set the 'header_title' and 'header_details' + template variables. Other, optional variables handled: + - header_subtitle - if set, doesn't prefix header_title with 'Setup: ', and is + used instead of header_title for the subtitle. + - message - if set, will be displayed as a success message (green) + - error - if set, will be displayed as an error message (red) +--%> + +
        +

        <%unless header_subtitle%>Setup: <%endunless%><%header_title%>

        +

        <%if header_subtitle%><%header_subtitle%><%else%><%header_title%><%endif%>

        + <%if message%>
        Results: 
        <%message%>
        <%endif%> + <%if message_pre%>
        Results: 
        <%message_pre%>
        <%endif%> + <%if error%>
        Error: 
        <%error%>
        <%endif%> +

        <%header_details%>

        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_style.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_style.html new file mode 100644 index 0000000..87e1d03 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_style.html @@ -0,0 +1,167 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_update_checker.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_update_checker.html new file mode 100644 index 0000000..13032a4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/include_update_checker.html @@ -0,0 +1,131 @@ + + +

        Checking for available program updates...

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/language.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/language.txt new file mode 100644 index 0000000..19d4cd8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/language.txt @@ -0,0 +1,336 @@ +$VAR = { + 'CSSEDITOR_INVALID_CSS' => 'Invalid CSS file selected.', + 'CSSEDITOR_INVALID_FILENAME' => 'You have entered an invalid filename. The filename may only contain alphanumeric characters, dashes and underscores, and must end with .css', + 'CSSEDITOR_INVALID_TPL' => 'Invalid template set selected.', + 'DATE_UNIT_DAY' => 'Day', + 'DATE_UNIT_DAYS' => 'Days', + 'DATE_UNIT_MONTH' => 'Month', + 'DATE_UNIT_MONTHS' => 'Months', + 'DATE_UNIT_WEEK' => 'Week', + 'DATE_UNIT_WEEKS' => 'Weeks', + 'DATE_UNIT_YEAR' => 'Year', + 'DATE_UNIT_YEARS' => 'Years', + 'GENERAL_ERROR' => 'An error has occurred.', + 'LINKS_TOP' => 'Home', + 'NEWSLETTER_ROOTCAT' => 'Home', + 'PAYMENT_ADD_INVALID' => 'Invalid value entered for %s: \'%s\'', + 'PAYMENT_ADD_NONE' => 'No value entered for %s', + 'PAYMENT_ADD_OPT_INVALID' => 'Invalid value entered for %s', + 'PAYMENT_CURRENCY_AED' => 'United Arab Emirates Dirham', + 'PAYMENT_CURRENCY_AFA' => 'Afghani', + 'PAYMENT_CURRENCY_ALL' => 'Lek', + 'PAYMENT_CURRENCY_ANG' => 'Netherlands Antilles Guilder', + 'PAYMENT_CURRENCY_AON' => 'New Kwanza', + 'PAYMENT_CURRENCY_ARS' => 'Argentine Peso', + 'PAYMENT_CURRENCY_AUD' => 'Australian Dollar', + 'PAYMENT_CURRENCY_AWG' => 'Aruban Guilder', + 'PAYMENT_CURRENCY_BAD' => 'Bosnian Dinar', + 'PAYMENT_CURRENCY_BBD' => 'Barbados Dollar', + 'PAYMENT_CURRENCY_BDT' => 'Taka', + 'PAYMENT_CURRENCY_BGL' => 'Lev', + 'PAYMENT_CURRENCY_BHD' => 'Bahraini Dinar', + 'PAYMENT_CURRENCY_BIF' => 'Burundi Franc', + 'PAYMENT_CURRENCY_BMD' => 'Bermudian Dollar', + 'PAYMENT_CURRENCY_BND' => 'Brunei Dollar', + 'PAYMENT_CURRENCY_BOB' => 'Boliviano', + 'PAYMENT_CURRENCY_BRL' => 'Real', + 'PAYMENT_CURRENCY_BSD' => 'Bahamian Dollar', + 'PAYMENT_CURRENCY_BWP' => 'Pula', + 'PAYMENT_CURRENCY_BZD' => 'Belize Dollar', + 'PAYMENT_CURRENCY_CAD' => 'Canadian Dollars', + 'PAYMENT_CURRENCY_CHF' => 'Swiss Franc', + 'PAYMENT_CURRENCY_CLP' => 'Chilean Peso', + 'PAYMENT_CURRENCY_CNY' => 'Yuan Renminbi', + 'PAYMENT_CURRENCY_COP' => 'Colombian Peso', + 'PAYMENT_CURRENCY_CRC' => 'Costa Rican Colon', + 'PAYMENT_CURRENCY_CUP' => 'Cuban Peso', + 'PAYMENT_CURRENCY_CVE' => 'Cape Verde Escudo', + 'PAYMENT_CURRENCY_CYP' => 'Cyprus Pound', + 'PAYMENT_CURRENCY_CZK' => 'Czech Koruna', + 'PAYMENT_CURRENCY_DJF' => 'Djibouti Franc', + 'PAYMENT_CURRENCY_DKK' => 'Danish Krone', + 'PAYMENT_CURRENCY_DOP' => 'Dominican Peso', + 'PAYMENT_CURRENCY_DZD' => 'Algerian Dinar', + 'PAYMENT_CURRENCY_ECS' => 'Ecuador Sucre', + 'PAYMENT_CURRENCY_EEK' => 'Kroon', + 'PAYMENT_CURRENCY_EGP' => 'Egyptian Pound', + 'PAYMENT_CURRENCY_ETB' => 'Ethiopian Birr', + 'PAYMENT_CURRENCY_EUR' => 'Euros', + 'PAYMENT_CURRENCY_FJD' => 'Fiji Dollar', + 'PAYMENT_CURRENCY_FKP' => 'Falkland Islands Pound', + 'PAYMENT_CURRENCY_FORMAT' => '$%s ', + 'PAYMENT_CURRENCY_GBP' => 'Pounds Sterling', + 'PAYMENT_CURRENCY_GHC' => 'Cedi', + 'PAYMENT_CURRENCY_GIP' => 'Gibraltar Pound', + 'PAYMENT_CURRENCY_GMD' => 'Dalasi', + 'PAYMENT_CURRENCY_GNF' => 'Guinea Franc', + 'PAYMENT_CURRENCY_GTQ' => 'Quetzal', + 'PAYMENT_CURRENCY_GWP' => 'Guinea - Bissau Peso', + 'PAYMENT_CURRENCY_GYD' => 'Guyana Dollar', + 'PAYMENT_CURRENCY_HKD' => 'Hong Kong Dollar', + 'PAYMENT_CURRENCY_HNL' => 'Lempira', + 'PAYMENT_CURRENCY_HRK' => 'Croatian Kuna', + 'PAYMENT_CURRENCY_HTG' => 'Gourde', + 'PAYMENT_CURRENCY_HUF' => 'Forint', + 'PAYMENT_CURRENCY_IDR' => 'Rupiah', + 'PAYMENT_CURRENCY_ILS' => 'Shekel', + 'PAYMENT_CURRENCY_INR' => 'Indian Rupee', + 'PAYMENT_CURRENCY_IQD' => 'Iraqi Dinar', + 'PAYMENT_CURRENCY_IRR' => 'Iranian Rial', + 'PAYMENT_CURRENCY_ISK' => 'Iceland Krona', + 'PAYMENT_CURRENCY_JMD' => 'Jamaican Dollar', + 'PAYMENT_CURRENCY_JOD' => 'Jordanian Dinar', + 'PAYMENT_CURRENCY_JPY' => 'Yen', + 'PAYMENT_CURRENCY_KES' => 'Kenyan Shilling', + 'PAYMENT_CURRENCY_KGS' => 'Som', + 'PAYMENT_CURRENCY_KHR' => 'Cambodia Riel', + 'PAYMENT_CURRENCY_KMF' => 'Comoro Franc', + 'PAYMENT_CURRENCY_KPW' => 'North Korean Won', + 'PAYMENT_CURRENCY_KRW' => 'Won', + 'PAYMENT_CURRENCY_KWD' => 'Kuwaiti Dinar', + 'PAYMENT_CURRENCY_KYD' => 'Cayman Islands Dollar', + 'PAYMENT_CURRENCY_KZT' => 'Tenge', + 'PAYMENT_CURRENCY_LAK' => 'Kip', + 'PAYMENT_CURRENCY_LBP' => 'Lebanese Pound', + 'PAYMENT_CURRENCY_LKR' => 'Sri Lanka Rupee', + 'PAYMENT_CURRENCY_LRD' => 'Liberian Dollar', + 'PAYMENT_CURRENCY_LSL' => 'Loti', + 'PAYMENT_CURRENCY_LTL' => 'Lithuanian Litas', + 'PAYMENT_CURRENCY_LVL' => 'Latvian Lats', + 'PAYMENT_CURRENCY_LYD' => 'Libyan Dinar', + 'PAYMENT_CURRENCY_MAD' => 'Moroccan Dirham', + 'PAYMENT_CURRENCY_MGF' => 'Malagasy Franc', + 'PAYMENT_CURRENCY_MKD' => 'Denar', + 'PAYMENT_CURRENCY_MMK' => 'Myanmar Kyat', + 'PAYMENT_CURRENCY_MNT' => 'Mongolia Tugrik', + 'PAYMENT_CURRENCY_MOP' => 'Pataca', + 'PAYMENT_CURRENCY_MRO' => 'Ouguiya', + 'PAYMENT_CURRENCY_MTL' => 'Maltese Lira', + 'PAYMENT_CURRENCY_MUR' => 'Mauritius Rupee', + 'PAYMENT_CURRENCY_MVR' => 'Rufiyaa', + 'PAYMENT_CURRENCY_MWK' => 'Kwacha', + 'PAYMENT_CURRENCY_MXN' => 'Mexico Peso', + 'PAYMENT_CURRENCY_MYR' => 'Malaysian Ringitt', + 'PAYMENT_CURRENCY_MZM' => 'Metical', + 'PAYMENT_CURRENCY_NAD' => 'Namibian Dollar', + 'PAYMENT_CURRENCY_NGN' => 'Naira', + 'PAYMENT_CURRENCY_NIO' => 'Cordoba Oro', + 'PAYMENT_CURRENCY_NOK' => 'Norwegian Krone', + 'PAYMENT_CURRENCY_NPR' => 'Nepalese Rupee', + 'PAYMENT_CURRENCY_NZD' => 'New Zealand Dollar', + 'PAYMENT_CURRENCY_OMR' => 'Rial Omani', + 'PAYMENT_CURRENCY_PAB' => 'Balboa', + 'PAYMENT_CURRENCY_PEN' => 'Nuevo Sol', + 'PAYMENT_CURRENCY_PGK' => 'New Guinea Kina', + 'PAYMENT_CURRENCY_PHP' => 'Philippine Peso', + 'PAYMENT_CURRENCY_PKR' => 'Pakistan Rupee', + 'PAYMENT_CURRENCY_PLN' => 'New Zloty', + 'PAYMENT_CURRENCY_PYG' => 'Guarani', + 'PAYMENT_CURRENCY_QAR' => 'Qatari Rial', + 'PAYMENT_CURRENCY_ROL' => 'Leu', + 'PAYMENT_CURRENCY_RUR' => 'Russian Ruble', + 'PAYMENT_CURRENCY_RWF' => 'Rwanda Franc', + 'PAYMENT_CURRENCY_SAR' => 'Saudi Riyal', + 'PAYMENT_CURRENCY_SBD' => 'Solomon Islands Dollar', + 'PAYMENT_CURRENCY_SCR' => 'Seychelles Rupee', + 'PAYMENT_CURRENCY_SDP' => 'Sudanese Pound', + 'PAYMENT_CURRENCY_SEK' => 'Sweden Krona', + 'PAYMENT_CURRENCY_SGD' => 'Singapore Dollar', + 'PAYMENT_CURRENCY_SHP' => 'St Helena Pound', + 'PAYMENT_CURRENCY_SIT' => 'Tolar', + 'PAYMENT_CURRENCY_SKK' => 'Slovak Koruna', + 'PAYMENT_CURRENCY_SLL' => 'Leone', + 'PAYMENT_CURRENCY_SOS' => 'Somalia Shilling', + 'PAYMENT_CURRENCY_SRG' => 'Suriname Guilder', + 'PAYMENT_CURRENCY_STD' => 'Dobra', + 'PAYMENT_CURRENCY_SVC' => 'El Salvador Colon', + 'PAYMENT_CURRENCY_SYP' => 'Syrian Pound', + 'PAYMENT_CURRENCY_SZL' => 'Swaziland Lilangeni', + 'PAYMENT_CURRENCY_THB' => 'Baht', + 'PAYMENT_CURRENCY_TJR' => 'Tajik Ruble', + 'PAYMENT_CURRENCY_TND' => 'Tunisian Dinar', + 'PAYMENT_CURRENCY_TOP' => 'Tonga Pa\'anga', + 'PAYMENT_CURRENCY_TPE' => 'Timor Escudo', + 'PAYMENT_CURRENCY_TRL' => 'Turkish Lira', + 'PAYMENT_CURRENCY_TTD' => 'Trinidad & Tobago Dollar', + 'PAYMENT_CURRENCY_TWD' => 'New Taiwan Dollar', + 'PAYMENT_CURRENCY_TZS' => 'Tanzanian Shilling', + 'PAYMENT_CURRENCY_UAH' => 'Ukrainian Hryvnia', + 'PAYMENT_CURRENCY_UGX' => 'Uganda Shilling', + 'PAYMENT_CURRENCY_USD' => 'U.S. Dollars', + 'PAYMENT_CURRENCY_UYU' => 'Uruguayan Peso', + 'PAYMENT_CURRENCY_VEB' => 'Venezuela Bolivar', + 'PAYMENT_CURRENCY_VND' => 'Viet Nam Dong', + 'PAYMENT_CURRENCY_VUV' => 'Vanuatu Vatu', + 'PAYMENT_CURRENCY_WST' => 'Tala', + 'PAYMENT_CURRENCY_XAF' => 'CFA Franc BEAC', + 'PAYMENT_CURRENCY_XCD' => 'East Caribbean Dollar', + 'PAYMENT_CURRENCY_XOF' => 'CFA Franc BCEAO', + 'PAYMENT_CURRENCY_XPF' => 'CFP Franc', + 'PAYMENT_CURRENCY_YER' => 'Yemeni Rial', + 'PAYMENT_CURRENCY_YUM' => 'Yugoslavian New Dinar', + 'PAYMENT_CURRENCY_ZAR' => 'Rand', + 'PAYMENT_CURRENCY_ZMK' => 'Zambian Kwacha', + 'PAYMENT_CURRENCY_ZRN' => 'New Zaire', + 'PAYMENT_CURRENCY_ZWD' => 'Zimbabwe Dollar', + 'PAYMENT_DIRECT_AuthorizeDotNet' => 'Authorize.Net', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_key' => 'Transaction key', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_key_description' => 'Your Authorize.Net transaction key (obtained from the Settings -> Security -> Transaction link in the Authorize.Net merchant interface)', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_password' => 'Account Password', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_password_description' => 'Your Authorize.Net account password, if required. It is recommended that you configure your Authorize.Net account NOT to require this password for transactions.', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_username' => 'Login ID', + 'PAYMENT_DIRECT_AuthorizeDotNet_account_username_description' => 'Your Authorize.Net account login ID', + 'PAYMENT_DIRECT_AuthorizeDotNet_confirmation_confirm' => 'Customer E-mail Confirmation', + 'PAYMENT_DIRECT_AuthorizeDotNet_confirmation_confirm_description' => 'This controls whether or not your customers will receive an e-mail confirmation regarding the payment processing', + 'PAYMENT_DIRECT_AuthorizeDotNet_confirmation_merchant' => 'Merchant Confirmation E-mail', + 'PAYMENT_DIRECT_AuthorizeDotNet_confirmation_merchant_description' => 'If set to a valid e-mail address, this address will be sent payment information, in addition to the address(es) defined in the Merchant interface', + 'PAYMENT_DIRECT_AuthorizeDotNet_currency' => 'Currency', + 'PAYMENT_DIRECT_AuthorizeDotNet_currency_description' => 'The currency in which orders will be charged', + 'PAYMENT_DIRECT_AuthorizeDotNet_test_mode' => 'Test Mode', + 'PAYMENT_DIRECT_AuthorizeDotNet_test_mode_description' => 'If enabled, transactions will be run in test mode. Although transactions will appear to be successful, no transactions performed will take effect. You should use this option when testing an account, but must leave it off for live credit card processing.', + 'PAYMENT_DIRECT_Moneris' => 'Moneris', + 'PAYMENT_DIRECT_Moneris_account_token' => 'API Token', + 'PAYMENT_DIRECT_Moneris_account_token2' => 'Store ID', + 'PAYMENT_DIRECT_Moneris_account_token2_description' => 'The eSELECTplus Store ID for your Moneris account', + 'PAYMENT_DIRECT_Moneris_account_token_description' => 'The API Token provided to you by Moneris', + 'PAYMENT_DIRECT_Moneris_test_mode' => 'Test Mode', + 'PAYMENT_DIRECT_Moneris_test_mode_description' => 'If enabled, a special Moneris testing server will be used instead of the live transactions server. You should use this option when testing direct payment support, but must leave it off for live credit card processing. Note that you must change the above API Token and Store ID, and use a special credit card number. For specific values, please see the information in section 8. How Do I Test My Solution of the Perl API Integration Guide, available here: https://www3.moneris.com/connect/en/documents/index.html. Also note that the testing environment approves/rejects payments based on the penny value of the transaction (eg. $xx.00 is approved, but $xx.01 will be rejected). See the Test Environment Penny Value Response Table document available at the previous URL for more details.', + 'PAYMENT_MANUAL' => 'Payment manually approved', + 'PAYMENT_REMOTE_2CheckOut' => '2CheckOut', + 'PAYMENT_REMOTE_2CheckOut_demo' => 'Demo Mode', + 'PAYMENT_REMOTE_2CheckOut_demo_description' => 'If enabled, transactions will be run in demo mode. Although transactions will appear to be successful, no transactions performed will take effect. You should use this option when testing an account, but must leave it off for live credit card processing.', + 'PAYMENT_REMOTE_2CheckOut_notes' => 'Note that in order to properly use 2CheckOut payment support, you need to enable the shopping cart Return URL. It should point to the Gossamer Links postback URL (e.g. http://www.example.com/cgi-bin/glinks/postback.cgi). You can set this from 2CheckOut\'s Account Homepage => Look & Feel => Approval URL. This is not necessary, however, if the domain you are using for Gossamer Links is the same as the domain your 2CheckOut account is associated with. If you have added the postback URL to your 2CheckOut account, then you will not be able to use your seller\'s account on any other program installation.', + 'PAYMENT_REMOTE_2CheckOut_secret_word' => '2CheckOut Secret Word', + 'PAYMENT_REMOTE_2CheckOut_secret_word_description' => 'Gossamer Links requires that you set up a "Secret Word" for your 2CheckOut account. This "Secret Word" helps keep your installation secure by allowing Gossamer Links to verify that incoming postbacks are in fact real 2CheckOut postbacks. You can set this from 2CheckOut\'s Account Homepage => Look & Feel => Secret Word.', + 'PAYMENT_REMOTE_2CheckOut_seller_id' => '2CheckOut Seller ID', + 'PAYMENT_REMOTE_2CheckOut_seller_id_description' => 'This is your 2CheckOut seller ID - payments will be directed to this account.', + 'PAYMENT_REMOTE_APPROVED' => 'Approved remote payment received from %s', + 'PAYMENT_REMOTE_CANCELLED' => 'Cancelled payment notification received from %s', + 'PAYMENT_REMOTE_INVALIDIP' => 'A payment notification was received from %s with an unauthorized IP address.', + 'PAYMENT_REMOTE_INVALIDPW' => 'A payment notification was received from %s with an invalid password.', + 'PAYMENT_REMOTE_Manual' => 'Manual', + 'PAYMENT_REMOTE_Manual_notes' => 'Note that in order to properly use the Manual payment support, you need to edit the template payment_manual_include.html which shows payment instructions to your users (i.e how to pay by money order, cheque etc). Once the payment has been approved manually, you can approve the payment from browsing Payment Logs Manual, click on Payment ID and Manually approve payment link', + 'PAYMENT_REMOTE_PayPal' => 'PayPal', + 'PAYMENT_REMOTE_PayPal_business_email' => 'PayPal Business E-mail', + 'PAYMENT_REMOTE_PayPal_business_email_description' => 'Your PayPal business (Seller\'s) e-mail address. This must be the primary e-mail address for the PayPal account. To send to a alternate e-mail address on the same account, see the "Recipient E-Mail" option below.', + 'PAYMENT_REMOTE_PayPal_button' => 'Payment Button', + 'PAYMENT_REMOTE_PayPal_button_description' => 'The button you select here will be shown on the payment page. If using a custom image, PayPal recommends that the image be specified via an https:// URL.', + 'PAYMENT_REMOTE_PayPal_color' => 'Background Color', + 'PAYMENT_REMOTE_PayPal_color_black' => 'Black', + 'PAYMENT_REMOTE_PayPal_color_description' => 'You may optionally decide to change the color displayed on the PayPal payment page from the default white to a black background.', + 'PAYMENT_REMOTE_PayPal_color_white' => 'White', + 'PAYMENT_REMOTE_PayPal_currency' => 'PayPal Currency', + 'PAYMENT_REMOTE_PayPal_currency_description' => 'The currency in which to charge users. Buyers will see the current exchange rate and the amount in their Primary Currency. Please note that changing the currency will cause pending and recurring payments to fail.', + 'PAYMENT_REMOTE_PayPal_image_url' => 'Image URL', + 'PAYMENT_REMOTE_PayPal_image_url_description' => 'If a URL to an image is specified here, the image will be shown on the PayPal purchase page. PayPal recommends that the image be specified via an https:// URL. The required size of the image is 150x50 pixels.', + 'PAYMENT_REMOTE_PayPal_note' => 'Payment Note Title', + 'PAYMENT_REMOTE_PayPal_note_description' => 'If set, buyers will be given the option to include a note with their payment. The value you enter into this field will be shown as the note title. This field can be a maximum of 30 characters. To show no note option, leave this field blank.', + 'PAYMENT_REMOTE_PayPal_notes' => 'Note that in order to properly use the PayPal payment support, you should enable Instant Payment Notification (IPN) on your PayPal account, and direct the IPN responses to the Gossamer Links postback (e.g. http://www.example.com/cgi-bin/glinks/postback.cgi). Note that if accessible via HTTPS, it is recommended to use an https:// URL instead of http://. Also see the optional IPN URL variable.', + 'PAYMENT_REMOTE_PayPal_notify_url' => 'Payment IPN URL', + 'PAYMENT_REMOTE_PayPal_notify_url_description' => 'This variable can be used to override the default IPN postback URL for your PayPal account. If set, this should point to the \'postback.cgi\' script in your user CGI directory - for example, if you login to Gossamer Links via http://www.example.com/cgi-bin/glinks/login.cgi, you would enter http://www.example.com/cgi-bin/glinks/postback.cgi here. This field is only required when setting up multiple IPN-aware scripts. If Gossamer Links is the only thing using IPN, it is recommended that you just set the IPN postback URL in your PayPal seller account settings.', + 'PAYMENT_REMOTE_PayPal_sandbox' => 'Use Sandbox', + 'PAYMENT_REMOTE_PayPal_sandbox_description' => 'This option turns on whether or not PayPal\'s testing environment Sandbox (see http://developer.paypal.com for more information) is be used.', + 'PAYMENT_REMOTE_PayPal_to_email' => 'PayPal Recipient E-Mail', + 'PAYMENT_REMOTE_PayPal_to_email_description' => 'Your PayPal business (Seller\'s) e-mail address at which you wish to receive payments. This only needs to be set when you want to send to an address other than the primary address on the account.', + 'PAYMENT_REMOTE_RECURRING_ACCEPTED' => 'Recurring payment notification received from %s', + 'PAYMENT_REMOTE_RECURRING_DECLINED' => 'Declined payment notification received from %s', + 'PAYMENT_REMOTE_REFUND' => 'Notification of payment refund received from %s', + 'PAYMENT_REMOTE_WorldPay' => 'WorldPay', + 'PAYMENT_REMOTE_WorldPay_callback_password' => 'Callback Password', + 'PAYMENT_REMOTE_WorldPay_callback_password_description' => 'The callback password (set in your WorldPay Customer Management System)', + 'PAYMENT_REMOTE_WorldPay_currency' => 'Currency', + 'PAYMENT_REMOTE_WorldPay_currency_description' => 'The currency in which users are charged. Note that if your account has been set up to handle multiple currencies, your customer may choose to pay in an alternate currency on the WorldPay payment page.', + 'PAYMENT_REMOTE_WorldPay_installation_id' => 'Installation ID', + 'PAYMENT_REMOTE_WorldPay_installation_id_description' => 'The WorldPay ID for this installation', + 'PAYMENT_REMOTE_WorldPay_md5_password' => 'MD5 Signature Password', + 'PAYMENT_REMOTE_WorldPay_md5_password_description' => 'A signature to use for MD5 signing purchases so that WorldPay can verify the validity of the purchase. This should be set here and in the WorldPay Customer Management System.', + 'PAYMENT_REMOTE_WorldPay_notes' => 'Note that in order to properly use the WorldPay payment support, you need to enable WorldPay callbacks. They should point to the Gossamer Links postback URL (e.g. http://www.example.com/cgi-bin/glinks/postback.cgi). If your Gossamer Links installation is available via HTTPS, it is recommended that you specify an https:// URL even if Gossamer Links is not normally accessed in this way.

        The "Store-builder used" option should be left on the default setting of "Other".

        In order to use recurring charges with WorldPay, you must also enable FuturePay with your WorldPay account and ensure that FuturePay callbacks are enabled.', + 'PAYMENT_REMOTE_WorldPay_test_mode' => 'Test Mode', + 'PAYMENT_REMOTE_WorldPay_test_mode_description' => 'If enabled, no actual transactions will be performed. You can set this to make all transactions succeed or fail.', + 'PAYMENT_TYPE_AMEX' => 'American Express', + 'PAYMENT_TYPE_DELTA' => 'Delta', + 'PAYMENT_TYPE_DINERS' => 'Diners Club', + 'PAYMENT_TYPE_DISC' => 'Discover', + 'PAYMENT_TYPE_EURO' => 'Eurocard', + 'PAYMENT_TYPE_JCB' => 'JCB', + 'PAYMENT_TYPE_MANUAL' => 'Manual', + 'PAYMENT_TYPE_MC' => 'MasterCard', + 'PAYMENT_TYPE_NOVA' => 'Nova', + 'PAYMENT_TYPE_PAYPAL' => 'PayPal', + 'PAYMENT_TYPE_SOLO' => 'Solo', + 'PAYMENT_TYPE_SWITCH' => 'Switch', + 'PAYMENT_TYPE_VISA' => 'VISA', + 'PAYMENT_TYPE_VISA_DEBIT' => 'VISA Debit', + 'VAL_CANTEMAIL' => 'Unable to send validation e-mail: %s', + 'VAL_GENERAL' => 'Unable to validate link, %s: %s', + 'dialog_create' => 'Creating %s table... ', + 'dialog_ok' => 'okay +', + 'error_failed_exists' => 'failed (table already exists) +', + 'error_failed_other' => 'failed (%s) +', + 'prompt_Add_Date' => 'Add Date', + 'prompt_Category_Template' => 'Category Template', + 'prompt_Contact_Email' => 'Contact Email', + 'prompt_Contact_Name' => 'Contact Name', + 'prompt_Date_Checked' => 'Date Checked', + 'prompt_Description' => 'Description', + 'prompt_Direct_Links' => 'Links (without subcats)', + 'prompt_Email' => 'Email', + 'prompt_ExpiryCounted' => 'Expiry optimization', + 'prompt_ExpiryDate' => 'Expiry Date', + 'prompt_ExpiryNotify' => 'Expiry notification sent', + 'prompt_FatherID' => 'Parent Category ID', + 'prompt_Footer' => 'Footer', + 'prompt_Full_Name' => 'Full Name', + 'prompt_Grouping' => 'Bookmark grouping', + 'prompt_Has_Changed_Links' => 'Has Changed Links', + 'prompt_Has_New_Links' => 'Has New Links', + 'prompt_Header' => 'Header', + 'prompt_Hits' => 'Hits', + 'prompt_ID' => 'ID', + 'prompt_LinkOwner' => 'Link Owner', + 'prompt_LinkExpired' => 'Free Link Expired', + 'prompt_Meta_Description' => 'Meta Description', + 'prompt_Meta_Keywords' => 'Meta Keywords', + 'prompt_Mod_Date' => 'Mod Date', + 'prompt_Name' => 'Name', + 'prompt_Newest_Link' => 'Newest Link', + 'prompt_Number_of_Links' => 'Number of Links', + 'prompt_Password' => 'Password', + 'prompt_Payment_Description' => 'Payment Description', + 'prompt_Payment_Mode' => 'Payment Mode', + 'prompt_PerPage' => 'Bookmarks per page', + 'prompt_Rating' => 'Rating', + 'prompt_ReceiveMail' => 'Receive Mailings', + 'prompt_ReviewID' => 'Review ID', + 'prompt_Review_ByLine' => 'Review By Line', + 'prompt_Review_Contents' => 'Review Contents', + 'prompt_Review_Date' => 'Review Date', + 'prompt_Review_ModifyDate' => 'Review Modify Date', + 'prompt_Review_GuestEmail' => 'Review Guest Email', + 'prompt_Review_GuestName' => 'Review Guest Name', + 'prompt_Review_LinkID' => 'Review Link ID', + 'prompt_Review_Owner' => 'Review Owner', + 'prompt_Review_Rating' => 'Review Rating', + 'prompt_Review_Subject' => 'Review Subject', + 'prompt_Review_Validated' => 'Review Validated', + 'prompt_Review_WasHelpful' => 'Review Was Helpful', + 'prompt_Review_WasNotHelpful' => 'Review Was Not Helpful', + 'prompt_SortField' => 'Bookmark sort field', + 'prompt_SortOrd' => 'Bookmark sort order', + 'prompt_Status' => 'Status', + 'prompt_Timestmp' => 'Timestamp', + 'prompt_Title' => 'Title', + 'prompt_URL' => 'URL', + 'prompt_Username' => 'Username', + 'prompt_Validation' => 'Validation Code', + 'prompt_Votes' => 'Votes', + 'prompt_isChanged' => 'isChanged', + 'prompt_isNew' => 'isNew', + 'prompt_isPopular' => 'isPopular', + 'prompt_isValidated' => 'Validated' +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_added.eml new file mode 100644 index 0000000..71db11b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_added.eml @@ -0,0 +1,23 @@ +To: <%config.db_admin_email%> +From: <%config.db_admin_email%> +Subject: Addition to Database: <%Title%> + +<%if isValidated eq 'Yes'%>The following link has been entered:<%else%>The following link is awaiting validation:<%endif%> + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact Email: <%Contact_Email%> + + Remote Host: <%Host%> + Referer: <%Referer%> + +<%if isValidated eq 'Yes'%>To remove, please go to:<%else%>To validate, please go to:<%endif%> + + <%config.admin_root_url%>/admin.cgi + +Sincerely, + +Links Manager diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_modified.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_modified.eml new file mode 100644 index 0000000..3ee2349 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/link_modified.eml @@ -0,0 +1,34 @@ +To: <%config.db_admin_email%> +From: <%config.db_admin_email%> +Subject: Modification to Database: <%New_Title%> + +<%if config.user_direct_mod%>The following link has been updated.<%else%>The following link was modified and is awaiting validation.<%endif%> + +ORIGINAL LINK: +=============================================== + Title: <%Original_Title%> + URL: <%Original_URL%> + Description: <%Original_Description%> + Category: <%Original_Category%> + Contact Name: <%Original_Contact_Name%> + Contact E-mail: <%Original_Contact_Email%> + +NEW LINK: +=============================================== + Title: <%New_Title%> + URL: <%New_URL%> + Description: <%New_Description%> + Category: <%New_Category%> + Contact Name: <%New_Contact_Name%> + Contact E-mail: <%New_Contact_Email%> + + Remote Host: <%Host%> + Referer: <%Referer%> + +To update, please go to: + + <%config.admin_root_url%>/admin.cgi + +Sincerely, + +Links Manager diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/local/link_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/local/link_added.eml new file mode 100644 index 0000000..68e6a10 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/local/link_added.eml @@ -0,0 +1,24 @@ +To: <%config.db_admin_email%> +Subject: Addition to Database: <%Title%> +From: <%config.db_admin_email%> +Cc: ashlea@slowtwitch.com + +<%if isValidated eq 'Yes'%>The following link has been entered:<%else%>The following link is awaiting validation:<%endif%> + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact Email: <%Contact_Email%> + + Remote Host: <%Host%> + Referer: <%Referer%> + +<%if isValidated eq 'Yes'%>To remove, please go to:<%else%>To validate, please go to:<%endif%> + + <%config.admin_root_url%>/admin.cgi + +Sincerely, + +Links Manager diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment.html new file mode 100644 index 0000000..435f5e4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment.html @@ -0,0 +1,19 @@ + + + + Gossamer Links - Payment + + + + + + + <body> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_cat_price.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_cat_price.html new file mode 100644 index 0000000..77f94af --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_cat_price.html @@ -0,0 +1,181 @@ +<%if save%> + <%Links::Payment::save_cat_price%> + <%if payment_config_invalid_fee%> + <%set message = "
        You entered an invalid signup charge!"%> + <%endif%> + <%if payment_config_invalid_term%> + <%set message .= "
        You entered an invalid signup term!"%> + <%endif%> + <%if payment_term_exists%> + <%set message .= "
        This term has been defined for this category!"%> + <%endif%> + <%if payment_invalid_cat_id%> + <%set message .= "
        Invalid category ID!"%> + <%endif%> + <%if config_saved_done%> + <%set message = "Your payment configuration has been saved successfully"%> + <%endif%> + <%if config_copied_done%> + <%set message = "Your payment configuration has been copied successfully"%> + <%endif%> +<%endif%> + + + + Gossamer Links - Payments - Payment Setup + + + +<%set header_title = "Payment Setup"%> +<%set header_description = "This page allows you to add and remove payment terms for a particular category."%> +<%include payment_header.html%> +<%set font_tag = ''%> +<%Links::Payment::load_cat_price($ID)%> +
        +
        + + + + + + + + + + +
        + + + + + + + + + + + + + +
        <%font_tag%>Category:<%font_tag%><%Name%>
        <%font_tag%>Payment Mode:<%font_tag%> + <%if Payment_Mode == 1%>Not Accepted<%endif%> + <%if Payment_Mode == 2%>Optional<%endif%> + <%if Payment_Mode == 3%>Required<%endif%> + +
        <%font_tag%>Back<%font_tag%>Copy global terms
        +
        +
        + + + + +
        + + <%if num_signup or num_renewal%> + + + + + + + <%if num_renewal and renewal_differs%> + + <%else%> + + <%endif%> + + <%endif%> + <%if num_recurring%> + + + + + <%endif%> + + + + + + + +
        <%font_tag%> + <%if num_renewal and renewal_differs%>Initial Terms: + <%else%>Payment Terms: + <%endif%> + + + + + + + + <%loop signup%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%ifnot term_unit%>Lifetime<%else%><%term_num%> <%term_unit%><%endif%>
        +
        <%font_tag%>Renewal Terms: + + + + + + + <%loop renewal%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%ifnot term_unit%>Lifetime<%else%><%term_num%> <%term_unit%><%endif%>
        +
        + <%font_tag%>Same as payment terms above. +
        <%font_tag%>Recurring Terms: + + + + + + + <%loop recurring%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%term_num%> <%term_unit%>
        + <%unless Links::Payment::recurring_enabled()%> + <%font_tag%>Note that recurring payments require + a supporting payment method. No appropriate payment method is + currently enabled. + <%endunless%> +
        <%font_tag%>New Term: + + + + +
        <%font_tag%> + <%Links::Payment::currency('')%> + checked="checked"<%endif%>> Single + checked="checked"<%endif%>> Renewal + checked="checked"<%endif%>> Recurring
        + + +
        +
        <%font_tag%>
        +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_details.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_details.html new file mode 100644 index 0000000..7a9c43e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_details.html @@ -0,0 +1,140 @@ +<%if manual_payment_approval%> +<%Links::Payment::admin_approve_payment($payment_id)%> + <%if manual_payment_success%> + <%set success_message = "This payment has been manually approved."%> + <%else%> + <%set error_message = "This payment has already been approved."%> + <%endif%> +<%endif%> + + + + + Gossamer Links - Payments - Payment Details + + + +<%Links::Payment::view_details($payment_id)%> + +<%set header_title = "Payment Details"%> +<%set header_description = "This page displays details for a given payment transaction."%> +<%include payment_header.html%> +
        +<%set font_tag = ''%> + +<%unless payments_id%> +
        + + + + +
        + + + + +
        + <%font_tag%>Payment not found! +
        +
        +<%else%> + +
        + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +<%unless payments_status eq 1%> + + + + +<%endunless%> +
        <%font_tag%>ID:<%font_tag%><%payments_id%>
        <%font_tag%>Link:<%font_tag%><%escape_html Title%> (details, modify)
        <%font_tag%>Type:<%font_tag%> + <%if payments_type eq 0%>Signup payment<%elsif payments_type eq 1%>Renewal payment<%elsif payments_type eq 2%>Recurring payment<%endif%> +
        <%font_tag%>Status:<%font_tag%> + <%if payments_status eq 0%>Pending + <%elsif payments_status eq 1%>Completed + <%elsif payments_status eq 2%>Declined + <%elsif payments_status eq 3%>Error + <%endif%> +
        <%font_tag%>Amount:<%font_tag%> + <%if payments_amount = 0%>Trial - <%endif%> + $<%payments_amount%> +
        <%font_tag%>Term:<%font_tag%> + <%if payments_term_num%><%payments_term_num%> <%payments_term_unit%><%else%>Unlimited<%endif%> +
        <%font_tag%>Method:<%font_tag%> + <%if payments_method eq 'trial'%>Trial + <%else%><%payments_method%> <%if payments_direct%>(Direct)<%elsif payments_remote%>(Remote)<%endif%> + <%endif%> +
        <%font_tag%>Intiated:<%font_tag%> + <%GT::Date::date_get($payments_start, '%ddd% %mmm% %d% %h%:%MM% %tt% %yyyy%')%> +
        <%font_tag%>Last Activity:<%font_tag%> + <%if payments_last == $payments_start%>No activity since payment was initiated. + <%else%><%GT::Date::date_get($payments_last, '%ddd% %mmm% %d% %h%:%MM% %tt% %yyyy%')%> + <%endif%> +
        <%font_tag%>Manual Approval:<%font_tag%> + + Manually approve payment + +
        +
        +
        +<%font_tag%>Payment Logs:
        +
        + + + + + + +<%loop logs%> + + + + + +<%endloop%> +
        <%font_tag%>Type<%font_tag%>Date<%font_tag%>Message
        <%font_tag%><%if paylogs_type eq 0%>Info<%elsif paylogs_type eq 1%>Accepted<%elsif paylogs_type eq 2%>Declined<%elsif paylogs_type eq 3%>Error<%elsif paylogs_type eq 4%>Manual<%endif%><%font_tag%><%GT::Date::date_get($paylogs_time, '%ddd% %mmm% %d% %h%:%MM% %tt% %yyyy%')%><%font_tag%><%unescape_html paylogs_text%>
        + +<%endunless%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_header.html new file mode 100644 index 0000000..06dd512 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_header.html @@ -0,0 +1,46 @@ + + + + +
        + + + + + + + +
        + <%header_title%> +
        +

        <%header_title%>

        +

        <%header_description%><%if header_description_2%><%header_description_2%><%endif%> 

        + <%if success_message%> +

        + <%success_message%> + <%if success_message_2%><%success_message_2%><%endif%> + <%if success_message_3%><%success_message_3%><%endif%> + <%if success_message_4%><%success_message_4%><%endif%> + <%if success_message_5%><%success_message_5%><%endif%> +

        + <%endif%> + <%if error_message%> +

        + <%error_message%> + <%if error_message_2%><%error_message_2%><%endif%> + <%if error_message_3%><%error_message_3%><%endif%> + <%if error_message_4%><%error_message_4%><%endif%> + <%if error_message_5%><%error_message_5%><%endif%> +

        + <%endif%> + <%if message%> +

        + <%message%> + <%if message_2%><%message_2%><%endif%> + <%if message_3%><%message_3%><%endif%> + <%if message_4%><%message_4%><%endif%> + <%if message_5%><%message_5%><%endif%> +

        + <%endif%> +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_log.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_log.html new file mode 100644 index 0000000..21e34d9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_log.html @@ -0,0 +1,128 @@ + + + +Gossamer Links - Payments - Payment Logs + + + +<%if log_id and delete_log%> + <%Links::Payment::delete_log($log_id)%> +<%endif%> +<%Links::Payment::view_log($log)%> + + + + + + +
        + + + + + + + +
        Payment Logs
        +

        Payment Logs

        +

        + This page displays a log of payment transactions that have occured.

        + Currently showing logs for + <%if log eq 0%>general payment information. + <%elsif log eq 1%>accepted payments. + <%elsif log eq 2%>declined payments. + <%elsif log eq 3%>payment errors. + <%elsif log eq 4%>manual payments. + <%endif%> + +

        +
        +
        +<%set font_tag = ''%> +
        + + + + +
        + <%font_tag%> + <%Links::paging($num_logs, $mh, $page, 5, 'want ...')%> + <%if page <= 1%> + << < + <%else%> + + << + < + + <%endif%> + <%loop paging%> + <%if is_current_page%><%page_num%> + <%else%><%page_num%> + <%endif%> + <%endloop%> + <%if dotdotdot%> + ... <%top_page%> + <%endif%> + <%if page >= $top_page%> + > >> + <%else%> + + > + >> + + <%endif%> + +<%set border_color = "grey"%> + + + +<%if log eq ''%> <%endif%> + + + + + + + <%loop logs%> + + + <%if log eq ''%> <%endif%> + + + + + + +<%endloop%> +
        LinkLog TypeDatePayment IDViewedDeleteMessage
        <%escape_html Title%> (details, modify) color="blue"<%endifnot%>><%if log eq 0%>Info<%elsif log eq 1%>Accepted<%elsif log eq 2%>Declined<%elsif log eq 3%>Error<%endif%> color="blue"<%endifnot%>><%GT::Date::date_get($paylogs_time, '%ddd% %mmm% %d% %h%:%MM% %tt% %yyyy%')%><%payments_id%><%if paylogs_viewed%>Yes<%else%>No<%endif%>x style="border-bottom: 1px solid <%border_color%>"<%endunless%>> color="blue"<%endifnot%>><%paylogs_text%>
        + + <%if page <= 1%> + << < + <%else%> + + << + < + + <%endif%> + <%loop paging%> + <%if is_current_page%><%page_num%> + <%else%><%page_num%> + <%endif%> + <%endloop%> + <%if dotdotdot%> + ... <%top_page%> + <%endif%> + <%if page >= $top_page%> + > >> + <%else%> + + > + >> + + <%endif%> + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add.html new file mode 100644 index 0000000..9c4a07a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add.html @@ -0,0 +1,52 @@ + + + Gossamer Links - Payments - Add Method + + + +<%set header_title = "Add Payment Method"%> +<%set header_description = "From this page you can add a new method of +accepting payments.

        + +Direct payment methods are methods where the user enters payment +information on your site, allowing you to control the exact content and +appearance. Since they involve the user entering credit card information on +your site, they will only work with SSL (HTTPS). +

        + +Remote payment methods allow you to process payments without the +requirement of an SSL-enabled website and certificate. The user will select +the service they want from your site, but to enter actual payment information +they will be taken to the remote payment providers website. +"%> + +<%include payment_header.html%> +<%set font_tag = ''%> +<%Links::Payment::methods%> +<%-- On the add page, we only want to show methods that aren't already set up --%> +<%set methods_listed = 0%> + +<%loop payment_methods%> +<%if payment_used%><%nextloop%><%endif%> +<%set methods_listed = 1%> +
        +<%include payment_methods_display_new.html%> +<%endloop%> + +<%unless methods_listed%> +
        + + + + +
        + + + + +
        <%font_tag%>No additional payment methods are available!
        +
        +<%endunless%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method.html new file mode 100644 index 0000000..4038236 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method.html @@ -0,0 +1,175 @@ +<%unless already_submitted%> + <%Links::Payment::add_method%> + <%if method_invalid%> + <%set error_message = 'Invalid payment method: '%> + <%set error_message_2 = $method%> + <%include payment_methods_add.html%> + <%endparse%> + <%elsif method_used%> + <%set error_message = 'Invalid payment method: '%> + <%set error_message_2 = $method%> + <%set error_message_3 = ' has already been set up'%> + <%include payment_methods_add.html%> + <%endparse%> + <%elsif method_failed%> + <%set error_message = "Unable to load payment method '"%> + <%set error_message_2 = $method%> + <%set error_message_3 = "':

        "%> + <%set error_message_4 = $method_failed_reason%> + <%include payment_methods_add.html%> + <%endparse%> + <%endif%> +<%endunless%> + + + + Gossamer Links - Payments - <%if modify%>Modify<%else%>Add<%endif%> Method - <%payment_name%> + + + +<%if modify%> + <%set header_title = "Modify"%> + <%set header_description = "Modify a previously configured payment method"%> +<%else%> + <%set header_title = "Add"%> + <%set header_description = "Configure a new payment method"%> +<%endif%> +<%set header_title .= " Payment Method"%> +<%include payment_header.html%> +
        + + + + +<%if modify%><%endif%> +<%set font_tag = ''%> +
        +<%set no_configure_link = 1%> +<%include payment_methods_display_new.html%> +
        + +<%if required_fields.length%> + + + + +
        + + + + + <%if payment_notes%> + + + + <%endif%> + + + +<%loop required_fields%> + + + + + + + + +<%endloop%> +
        <%font_tag%>Required Fields
        <%font_tag%><%payment_notes%>
        <%font_tag%>The following fields are required to set up a <%payment_name%> payment method:
        <%font_tag%><%if missing%><%field_title%>:<%else%><%field_title%>:<%endif%> + <%font_tag%> + <%if type eq 'YESNO'%> + checked<%endif%>>Yes + checked<%endif%>>No + <%elsif type eq 'TEXTAREA'%> + + <%elsif type eq 'SELECT'%> + + <%elsif type eq 'RADIO'%> + <%loop options%> + checked<%endif%>><%unescape_html string%>
        + <%endloop%> + <%else%><%--if type eq 'TEXT'--%> + + <%endif%> + +
         <%font_tag%><%field_description%>

        +
        + +
        +<%endif%> + +<%if optional_fields.length%> + + + + +
        + + + + + + + +<%loop optional_fields%> + + + + + + + +<%endloop%> +
        <%font_tag%>Optional Fields
        + <%font_tag%> + The following fields are optional parameters for the payment + method and are not required for the payment process. + +
        <%font_tag%><%if invalid%><%field_title%>:<%else%><%field_title%>:<%endif%> + <%font_tag%> + <%if type eq 'YESNO'%> + + <%elsif type eq 'TEXTAREA'%> + + <%elsif type eq 'SELECT'%> + + <%elsif type eq 'RADIO'%> + <%loop options%> checked<%endif%>><%unescape_html string%>
        + <%endloop%> + <%else%><%--if type eq 'TEXT'--%> + + <%endif%> + +
        <%font_tag%><%field_description%>

        +
        + +
        +<%endif%> + + + + + +
        + + + + +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method_submit.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method_submit.html new file mode 100644 index 0000000..88ed0a2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_add_method_submit.html @@ -0,0 +1,46 @@ +<%Links::Payment::add_method_submit%> +<%unless method_success%> + <%set already_submitted = 1%> + <%set error_message = 'Could not save payment method: '%> + <%if method_invalid%> + <%set error_message_2 = $method%> + <%set error_message_3 = ' is not a valid payment method.'%> + <%elsif method_used%> + <%set error_message_2 = $method%> + <%set error_message_3 = ' has already been set up.'%> + <%elsif method_failed%> + <%set error_message_2 = 'Could not load '%> + <%set error_message_3 = $method%> + <%set error_message_4 = ' payment module:
        '%> + <%set error_message_5 = $method_failed_reason%> + <%elsif method_insufficient%> + <%set error_message_2 = 'Insufficient information provided:

        '%> + <%set error_message_3 = $method_insufficient%> + <%else%> + <%set error_message_2 = 'An unknown error has occured.'%> + <%endif%> + <%include payment_methods_add_method.html%> + <%endparse%> +<%endunless%> + + + + Gossamer Links - Payments - <%if modify%>Modify<%else%>Add<%endif%> Method - <%payment_name%> + + + +<%set font_tag = ''%> +<%if modify%> + <%set header_title = "Modify Payment Method"%> + <%set success_message = "The changes to the payment method have been successfully saved."%> +<%else%> + <%set header_title = "Add Payment Method"%> + <%set success_message = "The payment method has been successfully added."%> +<%endif%> +<%set header_description = ""%> +<%include payment_header.html%> +
        +<%include payment_methods_display_existing.html%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_existing.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_existing.html new file mode 100644 index 0000000..b651459 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_existing.html @@ -0,0 +1,61 @@ + + + + +
        + + + + + +<%if payment_description%> + + + + +<%endif%> + + + + + + + + + + + + + + + +<%if payment_url%> + + + + +<%endif%> + +<%unless method_success%> + + + + + + + + +<%endunless%> +
        <%font_tag%>Name:<%font_tag%><%payment_name%>
        <%font_tag%>Description:<%font_tag%><%payment_description%>
        <%font_tag%>Type:<%font_tag%> + <%if payment_direct%>Direct (Requires HTTPS) + <%else%>Remote<%endif%> +
        <%font_tag%>Provides:<%font_tag%> + <%loop payment_types%><%unless first%>, <%endif%><%nbsp name%><%endloop%> +
        <%font_tag%>Recurring Payments:<%font_tag%> + <%if payment_recurring%>Supported<%else%>Not supported<%endif%> +
        <%font_tag%>URL:<%font_tag%><%payment_url%>
        <%font_tag%>Edit Method:<%font_tag%> + Click here to modify +
        <%font_tag%>Remove Method:<%font_tag%> + Click here to delete +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_new.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_new.html new file mode 100644 index 0000000..81a402e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_display_new.html @@ -0,0 +1,56 @@ + + + + +
        + + + + + +<%if payment_description%> + + + + +<%endif%> + + + + + + + + + + + + + + + +<%if payment_url%> + + + + +<%endif%> +<%unless no_configure_link%> + + + + +<%endunless%> +
        <%font_tag%>Name:<%font_tag%><%payment_name%>
        <%font_tag%>Description:<%font_tag%><%payment_description%>
        <%font_tag%>Type:<%font_tag%> + <%if payment_direct%>Direct (Requires HTTPS) + <%else%>Remote<%endif%> +
        <%font_tag%>Provides:<%font_tag%> + <%loop payment_types%><%unless first%>, <%endif%><%nbsp name%><%endloop%> +
        <%font_tag%>Recurring Payments:<%font_tag%> + <%if payment_recurring%>Supported<%else%>Not supported<%endif%> +
        <%font_tag%>URL:<%font_tag%><%payment_url%>
        <%font_tag%>Add Method:<%font_tag%> + + Configure payment method + +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_list.html new file mode 100644 index 0000000..554b240 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_list.html @@ -0,0 +1,41 @@ + + + Gossamer Links - Payments - List Methods + + + +<%set header_title = "List Payment Methods"%> +<%set header_description = "This page lists any payment methods that you have established for handling payments."%> + +<%include payment_header.html%> +<%set font_tag = ''%> + +<%Links::Payment::methods%> + +<%-- On the list page, we only want to show methods that are already set up --%> +<%set methods_listed = 0%> + +<%loop payment_methods%> +<%unless payment_used%><%nextloop%><%endif%> +<%set methods_listed = 1%> +
        +<%include payment_methods_display_existing.html%> +<%endloop%> + +<%unless methods_listed%> +
        + + + + +
        + + + + +
        <%font_tag%>No payment methods have been configured!
        +
        +<%endunless%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_remove.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_remove.html new file mode 100644 index 0000000..2a427a2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_methods_remove.html @@ -0,0 +1,70 @@ +<%Links::Payment::remove_method%> +<%if method_invalid%> + <%set error_message = 'Invalid payment method: '%> + <%set error_message_2 = $method%> + <%include payment_methods_list.html%> + <%endparse%> +<%elsif method_not_used%> + <%set error_message = 'Invalid payment method: '%> + <%set error_message_2 = $method%> + <%set error_message_3 = ' has not been set up'%> + <%include payment_methods_list.html%> + <%endparse%> +<%elsif method_failed%> + <%set error_message = "Unable to load payment method "%> + <%set error_message_2 = $method%> + <%set error_message_3 = ":

        "%> + <%set error_message_4 = $method_failed_reason%> + <%include payment_methods_list.html%> + <%endparse%> +<%elsif method_removed%> + <%set success_message = "Payment method "%> + <%set success_message_2 = $method%> + <%set success_message_3 = " has been successfully removed"%> + <%if no_methods_left%> + <%set error_message = "Warning: Payments will be disabled until at least one payment method is configured"%> + <%endif%> + <%include payment_methods_list.html%> + <%endparse%> +<%endif%> + + + + Gossamer Links - Payments - Remove Method - <%payment_name%> + + + +<%set header_title = "Remove Payment Method"%> +<%set header_description = "This page removes the payment method listed below.

        +If you are sure that you want to delete this payment method, click the Confirm button below."%> +<%include payment_header.html%> +
        + + + + +<%set font_tag = ''%> +
        +<%set no_configure_link = 1%> +<%include payment_methods_display_new.html%> +
        + + + + + +
        + + + + +
        + <%font_tag%> + Are you sure you want to delete this payment method?
        + + +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_nav.html new file mode 100644 index 0000000..0ba7f19 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_nav.html @@ -0,0 +1,78 @@ + + + + Gossamer Links - Payments - Nav + + + + + + + + + + + + + + + + + + + + + + + + <%-- Below only the number of new log entries is shown, however values for viewed log entries and + total log entries is available: + viewed: <%num_successful%>, <%num_declined%>, etc. + total: <%num_successful + $num_successful_unviewed%>, <%num_declined + $num_declined_unviewed%>, etc. --%> + + + + + + + + + + + + +
         Payment Setup
        +   About Payments
        +   Payment Setup
        +   +
         Payment Methods
        +   List Methods
        +   Add Method
        +   +
         Payment Logs
          + Successful + <%if num_successful_unviewed%>(<%num_successful_unviewed%>)<%endif%> +
        +   Declined + <%if num_declined_unviewed%>(<%num_declined_unviewed%>)<%endif%> +
        +   Info + <%if num_info_unviewed%>(<%num_info_unviewed%>)<%endif%> +
        +   Errors + <%if num_error_unviewed%>(<%num_error_unviewed%>)<%endif%> +
        +   Manual + <%if num_manual_unviewed%>(<%num_manual_unviewed%>)<%endif%> +
        +   +
         Payment Details
          + Payment ID: +
          +
          +
          +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_overview.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_overview.html new file mode 100644 index 0000000..0cd16e0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_overview.html @@ -0,0 +1,60 @@ + + + + Gossamer Links - Payments - Overview + + + + + + + + + +
        + +

        Payments

        + +
        + +

        From the Payment section + of your admin panel, Gossamer Links gives you the ability to set up + your Gossamer Links installation to accept payments through online + payment service providers. Currently, Gossamer Links can process payments + through Authorize.net, WorldPay, PayPal and Moneris.

        + +

        Basically, in order to + set up payment handling, you need to create one or more payment + methods. A payment method is simply a way of establishing that certain + types of payments should go to a particular payment service provider. + For example, setting up your installation to accept Paypal payments + would require a Paypal method. Likewise, setting up credit card + processing capabilities would also require setting up a payment method. + Through the configuration of payment methods, you define how payments + may be accepted, and with which online payment service provider those + payments are handled.

        + +

        Beyond the actual + processing of payments, there are several options available to + you:

        + +

        Payment Discounts

        +

        Multiple links + discount levels. You could be able to add as many discount + levels as you want.

        + +

        Renewals

        +

        Additionally, you can + define seperate renewal payment levels (e.g., when renewing, $30 gets + you an additional year, instead of $40 for the initial year).

        + +

        Recurring payments

        +

        You can also configure + recurring payments that will automatically be charged to users at specified + intervals.

        + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_setup.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_setup.html new file mode 100644 index 0000000..fe1a065 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/payment_setup.html @@ -0,0 +1,288 @@ +<%if save%> + <%Links::Payment::save_config%> + <%if payment_config_invalid_fee%> + <%set message = "
        You entered an invalid signup + charge!"%> + <%endif%> + <%if payment_config_invalid_discount%> + <%set message .= "
        You entered an invalid discount!"%> + <%endif%> + <%if payment_config_invalid_term%> + <%set message .= "
        You entered an invalid signup + term!"%> + <%endif%> + <%if renewal_warning_invalid%> + <%set message .= "
        You did not enter a valid renewal + warning!"%> + <%endif%> + <%if config_saved_done%> + <%set message = "Your payment configuration has been saved + successfully"%> + <%endif%> +<%endif%> + + + Gossamer Links - Payments - Payment Setup + + + +<%set header_title = "Payment Setup"%> +<%set header_description = "This page allows you to enable and configure the Gossamer Links payment system."%> + +<%include payment_header.html%> +
        +<%set font_tag = ''%> +<%Links::Payment::load_config%> + +
        + + + + + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%if num_signup or num_renewal%> + + + + + + + <%if num_renewal and renewal_differs%> + + <%else%> + + <%endif%> + + <%endif%> + <%if num_recurring%> + + + + + <%endif%> + + + + + + <%if payment_discounts%> + + + + + <%endif%> + + + + + + + +
        <%font_tag%>Payments Enabled:
        <%font_tag%> + +
        + <%font_tag%>If enabled, you will be able to receive payment from users for adding new links.

        + <%if payment_config_enabled and not payment_enabled%>No payment methods have been configured; payments will not be enabled until a method is configured.<%endif%> + +
        <%font_tag%>Expiry Notify:
        <%font_tag%> days
        <%font_tag%>A cron job will send a notification email to users X days before their links expire.

        <%font_tag%>Payment global option:
        <%font_tag%> + +
        <%font_tag%> + This option controls the default payment status of your directory. + Note that individual categories have the same option that will + override this global setting. If this option is set to "required", + then users must pay to add their links. If set to "optional" + payment categories will allow them to choose whether or not to pay + to add their links. If they pay, their links show up at the top of + the page with any other "paid" links, otherwise it shows at the + bottom below any paid links, mixed in with the unpaid links. If + set to "Not accepted", no payments will be allowed. +

        <%font_tag%>Link payment auto-validation:
        <%font_tag%> + CHECKED<%endif%>> Admin/Editors approves all links.
        + CHECKED<%endif%>> All paid links are automatically validated. +
         <%font_tag%>Note that manual payments are automatically validated on payment approval.

        <%font_tag%>Change expired links to free:
        <%font_tag%> + CHECKED<%endif%>> Changed expired links to free links.
        + CHECKED<%endif%>> Do not update expired links. +
         <%font_tag%> + This option allows you to define how Gossamer Links treats expired links in optional + categories - the links can either automatically become free links, in which case they + will still show up in the free listing of optional-payment categories, or they can be + left as expired and consequently will not show up in optional payment categories. +
        + Note: After changing this option, you must run the Repair Tables code (located + in the Database admin menu) +

        <%font_tag%>Payment description:
        + <%font_tag%>
        +
        <%font_tag%> + <%if num_renewal and renewal_differs%>Initial Terms: + <%else%>Payment Terms: + <%endif%> + + + + + + + + <%loop signup%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%ifnot term_unit%>Lifetime<%else%><%term_num%> <%term_unit%><%endif%>
        +
        <%font_tag%>Renewal Terms: + + + + + + + <%loop renewal%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%ifnot term_unit%>Lifetime<%else%><%term_num%> <%term_unit%><%endif%>
        +
        + <%font_tag%>Same as payment terms above. +
        <%font_tag%>Recurring Terms: + + + + + + + <%loop recurring%> + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Cost<%font_tag%>Term
        <%font_tag%><%font_tag%><%Links::Payment::currency($cost)%><%font_tag%><%term_num%> <%term_unit%>
        + <%unless Links::Payment::recurring_enabled()%> + <%font_tag%>Note that recurring payments require + a supporting payment method. No appropriate payment method is + currently enabled. + <%endunless%> +
        <%font_tag%>New Term: + + + + +
        <%font_tag%> + <%Links::Payment::currency('')%> + checked="checked"<%endif%>> Single + checked="checked"<%endif%>> Renewal + checked="checked"<%endif%>> Recurring
        + + +
        +
        <%font_tag%>Payment + Discounts: + + + + + + + + <%loop payment_discounts%> + + + + + + + <%endloop%> +
        <%font_tag%>Delete<%font_tag%>Num<%font_tag%>Discount<%font_tag%>Description
        <%font_tag%><%font_tag%> <%num%><%font_tag%> <%percent%>%<%font_tag%> <%description%>
        +
        <%font_tag%>New Payment Discount: + + + + + + + + + + + +
        <%font_tag%>Num of links:<%font_tag%>
        <%font_tag%>Discount percentage:<%font_tag%> %
        <%font_tag%>Discount description:<%font_tag%>
        +
        <%font_tag%>
        +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin.html new file mode 100644 index 0000000..079fc4d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin.html @@ -0,0 +1,19 @@ + + + +Gossamer Links - PlugIns + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_help.html new file mode 100644 index 0000000..e40cc53 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_help.html @@ -0,0 +1,45 @@ + + + +Gossamer Links - PlugIn - Help + + + + + + + + + + +
        + +

        PlugIns

        + +
        +

        Plugins are a powerful new + feature of Gossamer Links. They allow you to easily extend, enhance or alter + the functionality of any aspect of Gossamer Links. From your plugin manager, + you can easily install new plugins, check out Gossamer Threads to view the + latest plugins, or update existing ones, remove plugins that are no longer + useful and even temporarily disable/enable installed plugins.

        +

        Included in every copy is + also a powerful plugin authoring tool. It allows people with a little perl + knowledge to easily create plugins, and also share them with the Gossamer Links + community instantly. Be sure to read the Gossamer Links developers guide for + more information on enhancing Gossamer Links.

        +

        For more information on creating +your own plugins, please read the Gossamer +Links Developers Guide.

        +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager.html new file mode 100644 index 0000000..90e7d9d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager.html @@ -0,0 +1,17 @@ +<%Links::Plugins::manager%> + + + + +Gossamer Links - Plugin Wizard + + + + +

        <%Links::header ('Plugin Manager', 'The plugin manager lets you install, edit and remove plugins on your system.')%>

        + +<%content%> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_delete.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_delete.html new file mode 100644 index 0000000..d3f07c1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_delete.html @@ -0,0 +1,19 @@ +
        + + + + + + +

        About to delete plugin: <%plugin_name%> permanently!

        +

        This will remove the plugin from your system completely. Are you sure:

        +
        +
        +    + +
        +
        + + +

        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_download.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_download.html new file mode 100644 index 0000000..61b901b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_download.html @@ -0,0 +1,165 @@ + + +<%if num_plugins%> +

        + Install Plugins from Gossamer Threads
        + From here you can download plugins directly from Gossamer Threads to your server. +

        +

        There are <%num_plugins%> plugins available for download.

        + <%if results%>

        <%results%>

        <%endif%> + <%if error%>

        <%error%>

        <%endif%> + <%if speedbar%>

        Page: <%speedbar%>

        <%endif%> + + + + + + + + <%loop plugins%> + + + + + + + <%endloop%> +
        NameAuthorPrice 
        +
        + <%plg_name%> + <%if plg_language%>
        Language: <%plg_language%><%endif%> +
        Description: <%plg_description%> + <%if plg_support%>
        Support: <%plg_support%><%endif%> + <%if plg_support_url%>
        Support URL: <%plg_support_url%><%endif%> + <%if plg_updated%>
        Last updated: <%plg_updated%><%endif%> +
        +
        +
        + <%~if author_name%><%author_name%> + <%~else%>  + <%~endif~%> +
        +
        + <%~if plg_license == 2%> + <%~if plg_price%><%plg_price%><%else%> <%endif%> + <%~else%>Free + <%~endif~%> + + Version: <%plg_version%>
        + Installed: <%if installed%><%installed%><%else%>No<%endif%>
        + Download +
        + <%if speedbar%>

        Page: <%speedbar%>

        <%endif%> +<%else%> + + + + +
        +

        + Add New Plugins
        + You can add new plugins either by uploading a file, downloading from + a URL, or downloading directly from Gossamer Threads. +

        + <%if results%>

        <%results%>

        <%endif%> + <%if error_code or error%> +

        Unable to list plugins: + <%~if error_code eq 'invalid_product_id'%> + Invalid product ID. Please contact support@gossamer-threads.com + referencing this error. + <%~elsif error_code starts 'admin_path_mismatch'%> + Unable to list plugins: Your admin path does not match the admin path stored on the plugin server. + <%~if error_code ends '_reset'%> +

        You can reset the admin path stored on the Gossamer Threads plugin server a limited number of + times from the licensed download area. + <%~endif%> + <%~elsif error_code%> + You are not authorized to connect to the plugin server. Please contact + support@gossamer-threads.com for more information + and reference status: '<%error_code%>' + <%~else%> + <%error%> + <%~endif~%> +

        + <%endif%> +
        + + + +

        List Plugins on Gossamer Threads

        +
        +
        + + + +

        Install from URL:

        +
        +
        + + + +

        Install from File:

        +
        +
        +<%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit.html new file mode 100644 index 0000000..9f98a82 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit.html @@ -0,0 +1,87 @@ +<%if results%> +

        <%results%>

        +<%endif%> +<%if error%> +

        <%error%>

        +<%endif%> +<%if reload%> + +<%endif%> + +
        + + + + + + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%options%> + <%menu%> + <%hooks%> +
        Plugin Details +
         
        + Plugin: + + <%plugin_name%> +
        + Version: + + <%version%> +
        + Author: + + <%author%> +
        + License: + + <%license%> +
        + Description: + + <%description%> +
         
        +
        +
        +
        + + + + +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit_files.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit_files.html new file mode 100644 index 0000000..27e8f71 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_edit_files.html @@ -0,0 +1,123 @@ +<%if results%> +

        <%results%>

        +<%endif%> +<%if error%> +

        <%error%>

        +<%endif%> +<%if inst_error%> +

        <%inst_error%>

        +<%endif%> +<%if reload%> + +<%endif%> + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%files%> +<%if body%> + + + + + + + + + +<%endif%> +<%ifnot body%> + + + + + + + + + +<%endif%> +
        Plugin Details +
        + Plugin: + + <%plugin_name%> +
        + Version: + + <%version%> +
        + Author: + + <%author%> +
        + License: + + <%license%> +
        + Description: + + <%description%> +
         
        Plugin Files +
         
        Edit <%body_name%>: +
        +
        + + + + + + +
        +
         
        Add New File: +
        + + + + + + + + Upload File:
        + Filename: +
        +
        + +

        + +
        +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_list.html new file mode 100644 index 0000000..9673523 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_list.html @@ -0,0 +1,21 @@ +<%if results%> +

        <%results%>

        +<%endif%> +<%if error%> +

        <%error%>

        +<%endif%> + +<%if installed%> +

        <%installed%>

        +<%endif%> +<%if uninstalled%> +

        <%uninstalled%>

        +<%endif%> + +<%if reload%> + +<%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_install.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_install.html new file mode 100644 index 0000000..9fd2b65 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_install.html @@ -0,0 +1,40 @@ +
        + + + + +

        About to install plugin: <%plugin_name%>

        + +<%if error%> +

        Error loading plugin: <%error%>

        +<%endif%> + +<%if instructions%> +

        Please read the following instructions from the <%plugin_name%> author: +

        +
        +
        + <%instructions%> +
        +
        +

        +<%endif%> + +

        + +<%if confirm%> + +

        Plugin Exists!

        +

        <%plugin_name%> plugin already exists. Do you want to overwrite version <%old_version%> with <%new_version%>:

        +    +    + +

        +<%endif%> +<%ifnot confirm%> +
        +
        +
        +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_uninstall.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_uninstall.html new file mode 100644 index 0000000..d6c5b28 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_manager_pre_uninstall.html @@ -0,0 +1,31 @@ +
        + + + + +

        About to remove plugin: <%plugin_name%>

        + +<%if error%> +

        Error loading plugin: <%error%>

        +<%endif%> + +<%if instructions%> +

        Please read the following instructions from the <%plugin_name%> author: +

        +
        +
        + <%instructions%> +
        +
        +

        +<%endif%> + +

        + +
        +
           + +
        +
        + +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_nav.html new file mode 100644 index 0000000..7e87bc0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_nav.html @@ -0,0 +1,26 @@ + + + +Gossamer Links - PlugIn - Nav + + + + + + + + + + + + + <%Links::Plugins::admin_menu%> +
         Plugin Tools
          Plugin Manager
        +   Plugin Download
        +   Plugin Wizard
        +   About Plugins
        +  
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard.html new file mode 100644 index 0000000..2ec3ad5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard.html @@ -0,0 +1,17 @@ +<%Links::Plugins::wizard%> + + + + +Gossamer Links - Plugin Wizard + + + + +

        <%Links::header ('Plugin Wizard', 'This wizard will walk you through some questions and create a plugin shell for you to use.')%>

        + +<%content%> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step1.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step1.html new file mode 100644 index 0000000..d7429cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step1.html @@ -0,0 +1,60 @@ + + + + +
        + + + + +
        + + Plugin Wizard: Step 1 - Name your plugin +
        + + + + +
        + + Welcome to the plugin wizard. This wizard will ask you a few questions + about your plugin, and then create an install template and code + template which you can edit later. +

        To begin with, we need to know the name of your plugin. The name + will be used to determine the package the plugin resides in, so it + must be a valid perl package space. You should start with capitals, + and capitalize words as in: SearchLogger or SearchCache.

        + +<%if error%> +

        <%error%>

        +<%endif%> + + + + + + +<%if edit%> + + + + +<%endif%> +
        Create new plugin named: +
        + + + + +
        +
        Use existing plugin: +
        + + + + <%edit%> +
        +
        +
        +
        + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step2.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step2.html new file mode 100644 index 0000000..efc7913 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step2.html @@ -0,0 +1,85 @@ +
        + + + + + + + + +
        + + + + +
        + + Plugin Wizard: Step 2 - Meta Information for <%plugin_name%> +
        + + + + +
        + + Now we need to know a few more details about your plugin. This will be + used in displaying information about your plugin such as author, + description and most importantly version number. +

        It's essential to keep + a version number for your plugin. When people update the plugin from + the web, they can easily tell if the version they have is older then + the latest version, and can update as required.

        +<%if error%> +

        <%error%>

        +<%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + +
        Version: +

        +
        Author: + +
        URL: + +
        License: + +
        Gossamer Links Version Required: + +
        Description: + +
        +
        +
        +
        +
        +
        +
        +
        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step3.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step3.html new file mode 100644 index 0000000..7e71aff --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step3.html @@ -0,0 +1,77 @@ + + + + + +
        + + + + +
        + + Plugin Wizard: Step 3 - Plugin Hooks for <%plugin_name%> +
        + + + + +
        +
        + + + + + + Now you need to decide what hooks, if any, the plugin will use. +

        If your plugin needs + to override or enhance an existing part of code, then you most likely + need to register some hooks. If you are adding new functionality, then + you may just skip this section entirely.

        +<%if error%> +

        <%error%>

        +<%endif%> +<%if results%> +

        <%results%>

        +<%endif%> +<%if hooks%> +

        Existing Hooks:

        +<%hooks%> +

        +

        +<%endif%> +

        Add New Hook:

        + + + + + + + + + + + + + +
        Name +
        Type
        Code
        +

        +

        +
        +
        + +
        + + + + + +
        +
        +
        + +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step4.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step4.html new file mode 100644 index 0000000..4678b93 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step4.html @@ -0,0 +1,73 @@ + + + + + +
        + + + + +
        + + Plugin Wizard: Step 4 - Plugin Admin Menu for <%plugin_name%> +
        + + + + +
        +
        + + + + + + Now you need to decide what menu options, if any, you want to be displayed + to the user. If you provide admin menu options, for the user to interact with + the plugin, you should provide the name you want displayed, and the URL + you want it to go to. +

        To run a function in your + code, the URL should look like:

        +    plugin.cgi?do=plugin&plugin=<%plugin_name%>&func=yourfunc

        + This will run the function called yourfunc. You are responsible for printing + headers and any output you want.

        + +<%if error%> +

        <%error%>

        +<%endif%> +<%if results%> +

        <%results%>

        +<%endif%> +<%if menu%> +

        Existing Options:

        +<%menu%> +

        +

        +<%endif%> +

        Add New Menu:

        + + + + + + + + + +
        Name
        URL
        +

        +

        +
        +
        + +
        + + + + + +
        +
        +
        +
        \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step5.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step5.html new file mode 100644 index 0000000..f5b4b38 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step5.html @@ -0,0 +1,111 @@ + + + + + +
        + + + + +
        + + Plugin Wizard: Step 5 - Plugin User Options for <%plugin_name%> +
        + + + + +
        +
        + + + + + + Now you need to decide what user options, if any, you want to allow the user + to change. You can set simple configuration variables here that will be available + to you inside of your plugin. Gossamer Links will provide an interface for the user + to change these variables and provide the mechanism to store them. You can + also provide instructions which can explain to the user what the option + is for. +<%if error%> +

        <%error%>

        +<%endif%> +<%if results%> +

        <%results%>

        +<%endif%> +<%if user%> +

        Existing Options:

        +<%user%> +

        +

        +<%endif%> +

        Add User Option:

        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Name
        Type + +
        Default Value
        Form Names
        + (Stored in Database)
        + Only for checkbox, multi-select or radio forms
        +
        + +
        Form Value
        + (Stored in Database)
        + Only for checkbox, multi-select or radio forms
        +
        + +
        Instructions +
        +

        +

        + +
        + +

        + +
        + + + + + +
        +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step6.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step6.html new file mode 100644 index 0000000..2dcdb87 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step6.html @@ -0,0 +1,86 @@ + + + + + +
        + + + + +
        + + Plugin Wizard: Step 6 - Included Files for <%plugin_name%> +
        + + + + +
        +
        + + + + + + Quite often you will need to bundle some extra files with your plugin, be it + a user cgi script, some images, whatever. From here you + can add files to be included in your plugin, and where you would like them + placed. + +<%if error%> +

        <%error%>

        +<%endif%> +<%if results%> +

        <%results%>

        +<%endif%> +<%if files%> +

        Existing Files:

        +<%files%> +

        +

        +<%endif%> +

        Add New File:

        + + + + + + + + + + + + + + + + + + + + +
        Filename
        Place Into +
        File
        or
        Body
        +

        +

        + +
        + +

        + +
        + + + + + +
        +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step7.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step7.html new file mode 100644 index 0000000..8efd0be --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step7.html @@ -0,0 +1,60 @@ +
        + + + + + + + + + +
        + + + + +
        + + Plugin Wizard: Step 7 - Install Information for <%plugin_name%> +
        + + + + +
        +Gossamer Links +provides the plugin author to display a message before your plugin is +installed, and before it is removed. You should take this chance to provide some +feedback to the user on what actions you are going to do, and what changes the +plugin will make. + +<%if error%> +

        <%error%>

        +<%endif%> + + + + + + + + + + + + + + + + + +
        Install Message
        UnInstall Message
        Install Code
        Uninstall Code
        +
        +
        + +

        + +
        +
        +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step8.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step8.html new file mode 100644 index 0000000..aac9c77 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/plugin_wizard_step8.html @@ -0,0 +1,40 @@ +
        + + + + + + + + + +
        + + + + +
        + + Plugin Wizard: All Finished! +
        + + + + +
        +Your +plugin file has been created, and an install file has been added to it. There is +also a Wizard.pm file, so if you ever need to re run the wizard, all your values +will be remembered. +

        You should now go to the Plugin +Editor and add your source code to make your plugin work!

        +
        +
        + +

        + +
        +
        +
        + +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_added.eml new file mode 100644 index 0000000..8802f87 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_added.eml @@ -0,0 +1,31 @@ +To: <%config.db_admin_email%> +From: <%config.db_admin_email%> +Subject: Addition to review database: <%Review_Subject%> + +<%if Review_Validated eq 'Yes'%>The following review has been entered:<%else%>The following review is awaiting validation:<%endif%> + +<%if Review_Rating~%> + Rating: <%Review_Rating%> +<%endif~%> + Subject: <%Review_Subject%> + By Line: <%Review_ByLine%> + Contents: <%Review_Contents%> + Date: <%Review_Date%> +<%~if Review_GuestName and Review_GuestEmail%> + Guest Name: <%Review_GuestName%> + Guest E-mail: <%Review_GuestEmail%> +<%endif%> + Remote Host: <%Host%> + Referer: <%Referer%> + +of the link: + + <%URL%> + +<%if Review_Validated eq 'Yes'%>To remove, please go to:<%else%>To validate, please go to:<%endif%> + + <%config.admin_root_url%>/admin.cgi + +Sincerely, + +Links Manager diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_modified.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_modified.eml new file mode 100644 index 0000000..6916dae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/review_modified.eml @@ -0,0 +1,36 @@ +To: <%config.db_admin_email%> +From: <%config.db_admin_email%> +Subject: Update to review database: <%New_Review_Subject%> + +<%if Review_Validated eq 'Yes'%>The following review has been updated.<%else%>The following review was modified and is awaiting validation.<%endif%> + +ORIGINAL REVIEW: +=============================================== + Rating: <%Original_Review_Rating%> + Subject: <%Original_Review_Subject%> + By Line: <%Original_Review_ByLine%> + Contents: <%Original_Review_Contents%> + Date: <%Original_Review_Date%> + +NEW REVIEW: +=============================================== + Rating: <%New_Review_Rating%> + Subject: <%New_Review_Subject%> + By Line: <%New_Review_ByLine%> + Contents: <%New_Review_Contents%> + Date: <%New_Review_Date%> + + Remote Host: <%New_Host%> + Referer: <%New_Referer%> + +of the link: + + <%URL%> + +<%if New_Review_Validated eq 'Yes'%>To remove, please go to:<%else%>To validate, please go to:<%endif%> + + <%config.admin_root_url%>/admin.cgi + +Sincerely, + +Links Manager diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup.html new file mode 100644 index 0000000..79672ec --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup.html @@ -0,0 +1,19 @@ + + + +Gossamer Links - Setup + + + + + + + <body bgcolor="#FFFFFF"> + + <p>Gossamer Links requires a frames compatible browser.</p> + + </body> + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_build.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_build.html new file mode 100644 index 0000000..8ec0eae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_build.html @@ -0,0 +1,580 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Build Options + <%include include_style.html%> + + + + +
        + + +<%set header_title = 'Build Settings'%> +<%set header_details = 'These options control how Gossamer Links builds its HTML pages.'%> +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +<%if config.payment.enabled%> + + + + + + + +<%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        General Build Settings:
        + Default template set to use. This affects which template set is used + when building HTML pages, or when calling the cgi + scripts without arguments. If you have different themes set up, then + they will show up as "<template set>.<theme>". +
        build_default_tpl + <%Links::Tools::tpl_dir_select($cfg_build_default_tpl, '(?:browser|admin)', '', 1)%> + +
        + Number of days old for a link to be considered new. +
        build_new_cutoff
        + This determines what links are placed in the What's Cool area. If > 1, + the top n links will be considered popular. If < 1, the top n% links + will be considered popular. +
        build_pop_cutoff
        + Have Gossamer Links automatically create a backup of the data every time you + build pages? +
        build_use_backup + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Whether or not Gossamer Links should generate a category list when a + category needs to be selected. If 'No' is selected, the user will have + to view the category they wish to add the link to before clicking on + 'Add a Link'. If you choose to display the category list, then you have + two choices: an AJAX category selector (recommended if you have a lot of + categories), or a simple select list dropdown. Note that users must have + javascript enabled and have a browser that supports XMLHttpRequest before + they can use the AJAX category browser. If you choose to use the AJAX + category selector, then it will also be used on the admin side. For it + to function correctly, your default template set must have the + treecats.xml file. +
        db_gen_category_list + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + A list of fields that will be set when a user adds a record. It will + override anything the user puts in. +
        add_system_fields + +
        + A comma separated list of template variables that are protected. These + variables will not accept input from CGI (ie. arguments passed in through + the web) and will default to an empty string if they aren't directly + passed in as variables to the templates. +
        protected_vars
        + Validation policy. The default and recommend setting is that all links + must be validated before being entered into the directory. However, you + can change this so user contributed links are auto-validated, or links + contributed by anonymous users are auto-validated. Note: no + validation email will be sent to the user for auto-validated links. +
        build_auto_validate + checked="checked" <%endif%>/> +
        + checked="checked" <%endif%>/> +
        + checked="checked" <%endif%>/> + +
        + Only allow additions from the following sites: +
        db_referers
        + A comma separated list of Links columns which, if updated, will update the + Timestmp of the categories the link is in. You should only need to add a + column to this list if you use the column in link.html, the column data + changes often, and are using "Build Changed". For example, if you use + <%Hits%> in link.html and don't add it to this list, then the + category page won't be built on "Build Changed" when the Hits is updated. +
        links_cols_update_category
        Page Display and Sorting Options:
        + The default sort order to use for sorting links on the Category page. +
        build_sort_order_category
        + Whether or not to show paid links first, above free links, on the Category page. +
        build_sort_paid_first + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + The default sort order to use for sorting links on the new page. +
        build_sort_order_new
        + The default sort order to use for sorting links on the cool page. +
        build_sort_order_cool
        + The default sort order to use for sorting links on the editor page. +
        build_sort_order_editor
        + Page spanning: if enabled, Gossamer Links will break up large numbers of links + in a category onto multiple pages. +
        build_span_pages + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        build_links_per_page
        + Whether or not to split apart the what's new listings into separate pages based on date. +
        build_new_date_span_pages + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + These options determines whether or not links will be grouped by category + on the New and Cool pages. +
        build_new_gb + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        build_cool_gb + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Column to use to sort the category listings. +
        build_category_sort
        + Use Yahoo-style related categories: this will put the related categories + grouped in with the main categories, prefixed with an @ sign. If you use + this, you can only sort alphabetically. +
        build_category_yahoo + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Number of columns your subcategory list will be divided into. Note that this option is deprecated - you should only need this if you are using version 2.x templates. +
        build_category_columns
        + HTML to use in table tag for subcategory listings. Note that this option is deprecated - you should only need this if you are using version 2.x templates. +
        build_category_table
        + Enable/Disable the ability to display pages dynamically using the + page.cgi script. If set to yes, you can specify a comma separated list of + values that will be preserved as the user moves from page to page. Not + usually necessary to change. +
        dynamic_pages + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        dynamic_preserve
        + A comma separated list of pages in which you wish to preserve sb, so, + cat_sb, cat_so and Links column (for filtering) values. These + sort/filtering options only work on category and detailed pages, but if + you have custom category/detailed pages, then you will want to add them + to the list. Regular expressions can be used. +
        dynamic_preserve_sort_pages
        + Generate 404 Status codes for requests to page.cgi that do not match a valid + category. This can be useful when you use rewrite rules to send all requests + to page.cgi. +
        dynamic_404_status + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Any URLs in the templates that begin with the build_root_url will get + transformed into a dynamic URL for use with page.cgi. If you have URLs + that should not be transformed, then add them to this list. You may use + config tags such as <%build_root_url%> and + <build_static_url%>. Enter one URL per line. +
        dynamic_no_url_transform + +
        + If enabled, extra whitespace in generated HTML will be + removed, reducing the size of generated HTML pages by + up to 20%. +
        compress + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        File and Directory Options:
        + If enabled, Gossamer Links will build a separate HTML page + for each link. +
        build_detailed + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Filename to use for the home page. If this is left blank, then the build_index option will be used for the filename. +
        build_home
        + Index page to use for directories; page that is pulled when you request a + directory. +
        build_index
        + Whether or not the build_index is appended to URLs. Turning off this + option allows you to switch between different index page types without + affecting bookmarked pages or search engine rank. Note that if you turn + this option off, then your webserver must be configured to use the + build_index as the index page. +
        build_index_include + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Page name to use for pages that span more than one page. The full name will be [build_more][page #][build_extension]. +
        build_more
        + Extension to use on non index pages. +
        build_extension
        + Whether or not the Full_Name format variable should behave like it did in + Links SQL (where it did no coalesce multiple _'s into a single _). If + this is a new installation, then keep this set to 'No'. If you have + upgraded from a previous version, and want to ensure all your urls are + kept the same, then set this to 'Yes (broken)'. The difference between + the 'Yes' and 'Yes (broken)' settings is that _'s are not coalesced for + the Full_Name variable in build_detail_format for the 'Yes' setting. +
        build_format_compat + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + This option controls how the directories for categories will be named. + Note that if your category names contain many or entirely foreign + characters, the ID-only option is recommended. The two "shortened" ... forms + substitute long portions (>20 characters) of the category name with + "...", removing either characters off the beginning or end of the name. + The shortened forms without ... simply remove extra characters without + substituting them. The advanced option can be used to specify a custom + format string, but is not recommended for casual users. See + Links::Tools::parse_format for more details. +
        build_category_format + + style="display: none"<%endif%> /> +
        + This option controls how dynamic URLs will look. The + "ID" setting will result in URLs such as + page.cgi?g=123;d=1 while the "Full_Name" setting will result + in URLs such as + page.cgi?g=Category/Name;d=1. Gossamer Links will always accept + both URL forms, this setting simply controls the + default when Gossamer Links generates dynamic-mode URLs. + You may alternatively choose another field, but be aware that this + will cause problems if the column does not contain unique values + for every category. +
        build_category_dynamic + + style="display: none"<%endif%> /> +
        + This option controls how detailed pages will be named. The default is + simply the link ID, but more complex paths are possible. If the format + does not contain the link ID, the link ID will be appended to the end of + the format (_LinkID). The "shortened" option substitutes portions of the + category name longer than 15 characters, and portions of the link title + longer than 20 characters with "...". The advanced option can be used + to specify a custom format string, but is not recommended for casual + users. Note: This option only applies when the + build_detailed option above is enabled. +
        build_detail_format + + style="display: none"<%endif%> /> +
        + Directory permissions to use, default to 777 so that you can remove the + directories from FTP/telnet as usually they are owned + by the web server. +
        build_dir_per
        + File permissions to set newly created pages to, use 666 if you want to + switch between building from telnet, and building from shell. Use 644 if + you are going to be running under cgiwrap, or only building from telnet. +
        build_file_per
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_date.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_date.html new file mode 100644 index 0000000..a4bf0ce --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_date.html @@ -0,0 +1,223 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Date Options + <%include include_style.html%> + + + + + + +
        + + +<%set header_title = 'Date Options'%> +<%set header_details = 'These settings control how dates are displayed in the +user side of Gossamer Links.

        +Hide'%><%else%><%set header_details .= '1">Show'%><%endif%> +<%set header_details .= ' date format help.'%> +<%include include_header.html%> + + + + style="display: none"<%endunless%>> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Date Format Help
        + You can change the format of any dates displayed to the user using these + settings. The following date formats are supported: +
        %yyyy%Four-digit year such as 2004
        %yy%Two-digit year such as 04
        %mmmm%Long month name such as January
        %mmm%Short month name such as Jan
        %mm%Numerical month such as 01
        %m%Numerical month without leading 0, such as 1
        %dddd%Long weekday name such as Sunday
        %ddd%Short weekday name such as Sun
        %dd%Numerical date such as 09
        %d%Numerical date without leading 0, such as 9
        Example Formats
        %yyyy%-%mm%-%dd%1999-12-25
        %dd%-%mmm%-%yyyy%12-Dec-1999
        %ddd% %mmm% %dd% %yyyy%Sat Dec 12 1999
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Date Options:
        + User date format. This should be how you want the user to see your dates. +
        date_user_format
        + Expiry date format. This should be how you want the expiry date to be + displayed. +
        date_expiry_format
        + Review date format. This is the format used to display review dates. +
        date_review_format
        + Long user date format. This should be how you want the user to see long + dates. +
        date_long_format
        + Date offset. How many hours to offset the date from your web server to + your local time. +
        date_offset
        + Short day names (comma separated list). +
        date_days_short
        + Long day names (comma separated list). +
        date_days_long
        + Short month names (comma separated list). +
        date_month_short
        + Long month names (comma separated list). +
        date_month_long
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_email.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_email.html new file mode 100644 index 0000000..909452d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_email.html @@ -0,0 +1,131 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: E-mail Options + <%include include_style.html%> + + + + +<%set header_title = 'E-mail Options'%> +<%set header_details = 'These options control how and when e-mails are sent.'%> +<%include include_header.html%> + +
        + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        E-mail Options:
        + This should be the e-mail address where all admin notices are sent; it is + also the Reply-To on any outgoing e-mail notices. +
        db_admin_email
        + If you are on a UNIX server, set db_mail_path to the location of + sendmail. If using a Windows server, set db_smtp_server to the hostname + for your SMTP server. Note: Only one should be set! +
        db_smtp_server
        db_mail_path
        + Should Gossamer Links automatically send notices to the administrator + when a user has requested to add or modify a link or review? +
        admin_email_add + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        admin_email_mod + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        admin_email_review_add + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        admin_email_review_mod + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Should Gossamer Links notify a user that their link or review addition/modification has + been validated? +
        email_add + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        email_mod + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        email_review_add + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Should Gossamer Links notify a user that their payment has been received and + their link has been added? +
        email_payment + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_env.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_env.html new file mode 100644 index 0000000..71ad15d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_env.html @@ -0,0 +1,20 @@ + + + + + Gossamer Links Setup: Environment + <%include include_style.html%> + + + + +<%set header_title = 'Environment'%> +<%set header_details = 'The following is information about your system and is +provided for troubleshooting and debug information.'%> +<%include include_header.html%> + +<%Links::environment('0')%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_first.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_first.html new file mode 100644 index 0000000..375e52a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_first.html @@ -0,0 +1,53 @@ +<%Links::Config::load_vars%> + + + +Gossamer Links Setup: Step 1 + + + +
        + + + + + + + + +
        +

         Gossamer Links + Setup +

        +
        + +
        +


        + Welcome to Gossamer Links. Before + you can begin to use the program, we need to setup Gossamer Links to work with your + SQL server. You will need to know the following information before proceeding:

        +
          +
        • SQL Server Type - common + types include MySQL, MSSQL, Oracle
        • +
        • SQL Hostname - which + computer your SQL server resides on, typically this is localhost.
        • +
        • SQL Database Name - which + database you want Gossamer Links to use.
        • +
        • SQL Username/Password - a + username/password to log on to the SQL database.
        • +
        +

        If you don't know the answer + to any of this, please contact your ISP. If you are still stuck, please visit + our support page at:

        +
        +

        http://gossamer-threads.com/scripts/support/

        +
        +
        +

          +
        +   +
        +
        +

        <%include copyright.html%>

        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_help.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_help.html new file mode 100644 index 0000000..2e86fae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_help.html @@ -0,0 +1,28 @@ + + + +Gossamer Links - Setup - Help + + + + + + + + + +
        +

        Setup

        +
        +

        From here you can + alter any of the options that Gossamer Links uses, from your database + settings to your email address. Also, if you have made a mistake, with + a simple click you can restore the system defaults.

        +

        Feel like starting + over? Simply run the Initial Setup, and Gossamer Links will restore itself + to it's original state.

        +

         

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_misc.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_misc.html new file mode 100644 index 0000000..56e02fe --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_misc.html @@ -0,0 +1,228 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Miscellaneous Options + <%include include_style.html%> + + + + +
        + + +<%set header_title = 'Miscellaneous Options'%> +<%set header_details = 'These are other options that you can change.'%> +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Miscellaneous Options:
        + Registration Number: +
        reg_number
        + Use Non Parsed Headers. You should leave this as is unless you are + running under a cgi wrapper and nph scripts don't work (cobalt raq for + example) +
        nph_headers + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This is the character set that will be sent to the web browser for admin + and browser pages. This should match the character set of your actual + link data that is stored in the database. The character set will also be + used in the luna template set, but can be changed to something else (e.g. + if you have template sets in several languages), by modifying the + include_common_head.html template. +
        header_charset + +
        + Gossamer Links debugging. If enabled, debugging information will be displayed + in the error logs, and extra debugging information will be displayed on + any fatal error screen. Leaving this enabled is not recommended as it + reduces performance. +
        debug_level + +
        + Custom Error Handler. Gossamer Links will display the following HTML on any + error message that is generated. If left blank, the default error will be + shown. You can only use two template tags in this: <%error%> for + the error message, and <%environment%> for a complete debug + message. +
        error_message + +
        + Disable Site. Gossamer Links will display the 'error.html' template for any + access to a user cgi script. +
        disabled + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Banned Hosts. Enter a list of hostnames and/or IP addresses to ban, one + per line. '?' may be used to match any single character, and '*' to match + anything (including nothing). The template 'banned.html' will be + displayed to anyone attempting to access any dynamic section of the site + from a banned address. +
        bans + +
        + Check for updates on home page. If enabled, a check for updates will be + performed on the "Home" page of the Gossamer Links admin panel. This + check can save you time by making it not necessary to constantly check + the "Updates" page for program updates. +
        updates_check_on_home + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Display the advanced re-run upgrade code menu on the Updates admin menu. + This code is not normally needed in Gossamer Links and its use is not + recommended unless advised by Gossamer Threads support staff. +
        show_upgrade_rerun + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This setting controls which date we should use for the Add Date when validating links. + If this option is set to "Original," then the date that the link was submitted will be + used. If "Current" is selected, then the date the link was validated will be used. +
        link_validate_date + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_nav.html new file mode 100644 index 0000000..7b21491 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_nav.html @@ -0,0 +1,34 @@ + + + + + Gossamer Links - Setup - Nav + + <%include include_style.html%> + + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_pass.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_pass.html new file mode 100644 index 0000000..5f96b18 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_pass.html @@ -0,0 +1,73 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: User Options + <%include include_style.html%> + + + + +<%set header_title = 'Admin Password'%> +<%set header_details = "From here, you can manage admin usernames and +passwords. This uses Apache's .htaccess method of password protecting your +directory and will not work on servers other than Apache."%> +<%include include_header.html%> + +
        + + + + + + + + + + + + + + + + + +
        Add New User:
        Username: value="<%admin_username%>"<%endif%> size="20" />
        Password:
        Confirm Password:
        + +
        + +
        +
        + +<%Links::Tools::auth_users%> +<%if htpasswd_users_count%> +
        + + + + + + + + + + + +
        Delete User:
        username: + +
        + +
        + +
        + +
        +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_path.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_path.html new file mode 100644 index 0000000..9d82bd9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_path.html @@ -0,0 +1,317 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Path and URL Settings + <%include include_style.html%> + + + + + + +
        + + +<%set header_title = 'Path and URL Settings'%> +<%set header_details = 'These are the only paths you should need to set in the +program. Most should be set appropriately during installation and should not +require changes.%> + +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%if not advanced%> + + + + + + + + <%else%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + <%endif%> + +
        Path and URL Settings
        + This should be the URL (starting with http://) to the directory where + your admin files are. No trailing slash please. +
        admin_root_url
        + This should be the PATH (starting with a / or a drive letter) to the + directory where your admin files are. No trailing slash please. +
        admin_root_path
        + This should be the URL where your public cgi scripts (add.cgi, + modify.cgi, search.cgi, etc.) are located. No trailing slash. +
        db_cgi_url
        + This should be the URL via HTTPS where your public cgi scripts are + (add.cgi, modify.cgi, search.cgi, etc.) are located. If this option is + left blank, the above db_cgi_url value will be used, with + 'http://' changed to 'https://'. This option can be ignored if not using + 'Direct' payment methods. No trailing slash. +
        db_cgi_url_https
        + This should be the URL where Gossamer Links will create its HTML pages. No + trailing slash. +
        build_root_url
        + This should be the PATH where Gossamer Links should create it's HTML pages. No + trailing slash. +
        build_root_path
        + This is the URL where static template files (images, javascript, css, etc.) reside. + No trailing slash. If you are running in dynamic mode, this should not be the same + as your build_root_url. +
        build_static_url
        + This should be the PATH where the static template files are located. No trailing slash. +
        build_static_path
        + FileMan Root Directory. Included in Gossamer Links is a copy of FileMan that + you can use to manage files from the web. It defaults to your Gossamer Links + admin directory, but you can change it here. +
        fileman_root_dir
        + This should be the path to perl. Windows users should include a drive + letter as well. +
        path_to_perl
        + Update other paths and URL's to reflect base? If selected, paths like + What's New, What's Cool, etc. will be automatically updated, otherwise + click here + to view them and set them manually. + +
        update_others
        Other Paths and URL's
        + The URL and path for the What's New page. +
        build_new_url
        build_new_path
        + The URL and path for the What's Cool page. +
        build_cool_url
        build_cool_path
        + The URL and path for the Top Rated page. +
        build_ratings_url
        build_ratings_path
        + The URL and path for the Detailed pages. +
        build_detail_url
        build_detail_path
        + This should be the URL where any image files used by Gossamer Links can be + found. No trailing slash. Note that this option is deprecated - you should + only need this if you are using version 2.x templates. Use the build_static_url option instead. +
        build_images_url
        + The URL to your CSS file. + Note that this option is deprecated - you should only need this if you are using version 2.x templates. +
        build_css_url
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_reset.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_reset.html new file mode 100644 index 0000000..ae7b0b4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_reset.html @@ -0,0 +1,17 @@ + + + +Gossamer Links Setup: Redo Setup + + + + +
        +

        Redo Setup +

        +This will rerun the initial setup. It will erase any existing Gossamer Links data, and reset your configuration +to the Gossamer Links defaults.

        +Proceed >> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_review.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_review.html new file mode 100644 index 0000000..01c46bf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_review.html @@ -0,0 +1,158 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Review Options + <%include include_style.html%> + + + + + + + +<%set header_title = 'Review Options'%> +<%set header_details = 'These options control how your review system behaves. +When your review.cgi script is called, these are the defaults it will use +unless you arguments are specifically passed in.'%> +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Review Options:
        + Users must be logged in to make a review: +
        user_review_required + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Review validation policy. Note that no validation e-mail will be sent to + the user for auto-validated reviews and that modifications to reviews will + also be auto-validated. +
        review_auto_validate + checked="checked" <%endif%>/> +
        + checked="checked" <%endif%>/> +
        + checked="checked" <%endif%>/> + +
        + Allow users to modify their reviews? +
        review_allow_modify + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + If users are allowed to modify their reviews, then how long do they have + (in minutes) to modify their review before the review cannot be modified? + Set this to 0 if you do not want a time restriction. +
        review_modify_timeout + minutes +
        + The maximum number of reviews a user can write per link. There is no + limit if this is set to 0. +
        review_max_reviews
        + How many reviews per page would you like to display: +
        reviews_per_page
        + How would you like the reviews sorted: +
        review_sort_by + +
        + The order to sort reviews +
        review_sort_order + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Number of days old a review should be considered new: +
        review_days_old + days +
        + Convert line breaks in reviews to <br /> tags: +
        convert_br_tags + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + +

        + + +
        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_search.html new file mode 100644 index 0000000..6994d5b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_search.html @@ -0,0 +1,134 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: Search Options + <%include include_style.html%> + + + + +
        + + +<%set header_title = 'Search Options'%> +<%set header_details = 'These options control how your search engine behaves.'%> +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Search Options:
        + Default search behaviour. When your search.cgi script is called, these + are the defaults it will use unless you specifically provide other + parameters. +
        search_maxhits
        search_bool + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        search_substring + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + Enable/Disable the search highlighting of search results. +
        search_highlighting + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + This sets the number of colours that have been defined in the template + css file. These colours will be used to highlight the search terms of + search results. If there are more search terms used than colours, then + it will reuse the colours. The format for the css class name is: + searchhl-<number between 1 and # of colours> +
        search_highlight_colors
        + Enable/Disable the logging of queries that visitors perform. +
        search_logging + checked="checked" <%endif%>/> + checked="checked" <%endif%>/> +
        + The default sort orders for search results. These must relate to columns + in your Links or Category tables. Use 'score' by itself to return the + best matches first. +
        build_sort_order_search
        build_sort_order_search_cat
        + Determines whether to display and group your search results by + category. +
        build_search_gb + checked="checked" <%endif%>> + checked="checked" <%endif%>> +
        + By default, users can search on any field in your Links table by going to + search.cgi?FIELDNAME=SEARCHTERM. If you have fields you don't want users + to search on, you can list them here (comma separated list), and the + search.cgi will ignore them. +
        search_blocked
        + +
        + + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_second.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_second.html new file mode 100644 index 0000000..0164e34 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_second.html @@ -0,0 +1,88 @@ + + + +Gossamer Links Setup: Step 2 + + + +
        + + + + + + + +
        +

         Gossamer Links Setup - SQL Information +   + +

        +
        +
        +
        +<%if error%> +

        + Error: <%error%>

        +

        Please fix the error below and try again: +<%endif%> +<%ifnot error%> + +

        Please enter the following + information: +<%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

        + SQL Server Type:

        +
        SQL + Hostname:
        SQL + Database:
        SQL + Username:
        SQL + Password:
        Table Prefix
        Overwrite CHECKED<%endif%>>
        +

        Gossamer Links will verify the + program and create your SQL tables. If you have existing tables and would like + Gossamer Links to drop and remove your data, click on Overwrite.

        +
        +

          +
        +   +
        + +

        <%include copyright.html%>

        + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_sql.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_sql.html new file mode 100644 index 0000000..daa642a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_sql.html @@ -0,0 +1,103 @@ + +<%Links::SQL::load%> + + + + Gossamer Links Setup: SQL Information + <%include include_style.html%> + + + + + +
        + + +<%set header_title = 'SQL Server Settings'%> +<%set header_details = 'All data in Gossamer Links is stored in an SQL database. +This screen allows you to change which SQL server to use:'%> + +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        Current Settings:
        SQL Server Type: + +
        SQL Hostname:
        SQL Database:
        SQL Username:
        SQL Password:
        Table Prefix:
        + +

        If you make changes here, Gossamer Links needs to examine the new database. Your +choices are:

        + +

        + + +

        + +

        + + +

        + +

        + + +

        + +
        + +
        + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_third.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_third.html new file mode 100644 index 0000000..6f4520c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_third.html @@ -0,0 +1,38 @@ + + + +Gossamer Links Setup: Step 3 + + + +
        + + + + + + + +
        +

        Gossamer Links + Setup - All Done +

        +
        + +
        +<%if message%> +

        <%message%> +<%endif%> +


        + You can now proceed and use the + program, but are advised to look through the other setup options available by + clicking on setup above. If you had any problems, please hit back on your browser + and resubmit the form. +

        +
        +

          +
        +   +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_user.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_user.html new file mode 100644 index 0000000..4290d8d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/setup_user.html @@ -0,0 +1,285 @@ + +<%Links::Config::load_vars%> + + + + Gossamer Links Setup: User Options + <%include include_style.html%> + + + + + + +<%set header_title = 'User Options'%> +<%set header_details = 'These are user related options that you can change.'%> +<%include include_header.html%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
        User Options:
        + Does a user have to be validated before they can sign up? This will make + Gossamer Links send the user an email with a validation code that they will + need to enter before the user is activated. +
        user_validation + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This option controls whether or not to check that links submitted by users contain valid URLs. +
        user_link_validation + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Require users to signup before they can add or modify links? +
        user_required + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Require users to signup before they can rate links? +
        user_rate_required + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Allow users to modify links they own without validation (requires + user_required to be set to Yes)? +
        user_direct_mod + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Allow passwords to be emailed to users? +
        user_allow_pass + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This option controls whether or not to load links in a frame so the user can easily go back to the Gossamer Links installation or perform actions on the link. +
        framed_jump + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Enable Bookmarks? +
        bookmark_enabled + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + Default bookmark folder name +
        bookmark_folder_default_name
        + Bookmark folder limit +
        bookmark_folder_limit
        + Bookmark folders per page +
        bookmark_folders_per_page
        + The maximum number of bookmarks a user can save +
        bookmark_links_limit
        + The maximum number of bookmarks per page on the user list page +
        bookmark_links_per_page
        + Bookmark sort field +
        bookmark_links_sort
        + Bookmark sort order +
        bookmark_links_sort_order + +
        + The maximum number of users per page on the user list +
        bookmark_users_per_page
        + Enable Newsletter? +
        newsletter_enabled + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + If set, the newsletter system will be put into global newsletter mode, where it will only allow users to (un)subscribe to/from a single global category rather than individual categories. +
        newsletter_global_subscribe + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This is the maximum depth of the newsletter category tree to display on a page. +
        newsletter_max_depth
        + Use cookies to store session information, or pass it through the URL. Note that + URL sessions will not work with statically built pages. +
        user_sessions + checked="checked"<%endif%> /> + checked="checked"<%endif%> /> +
        + This is the domain for which any cookies set will work. If blank, + cookies will work for only the exact domain accessed. For example, if + your server is www.example.com and it is also accessed via example.com or + via anything.example.com you should set this to: '.example.com'. +
        user_cookie_domain
        + If set, the names of all cookies will be prefixed with this. Note that + changing this value will render all cookies invalid and all users will be + required to log in again. +
        user_cookie_prefix
        + Number of hours user sessions should last for. +
        user_session_length
        + +
        + + +
        +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_duplicate.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_duplicate.html new file mode 100644 index 0000000..b06c094 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_duplicate.html @@ -0,0 +1,63 @@ +<%Links::Tools::check_duplicates%> + + + +Gossamer Links - Tools - Check Duplicates + + + + + + +
        + + + + + + + +
        View Link + Status
        +

        Check + Duplicates

        +

        This allows you to quickly scan for duplicate + links, removing any that you don't want. +

        Your search returned <%total%> links.

        +
        + +<%if total%> +
        +
        + + + + +
        + +<%if toolbar%> + +<%endif%> + +<%output%> + +<%if toolbar%> + +<%endif%> +
        +

        Pages: <%toolbar%>

        +
        +

        Pages: <%toolbar%>

        +
        +
        + +
        +
        +
        +
        + +
        +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_expired_purge.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_expired_purge.html new file mode 100644 index 0000000..8135c55 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_expired_purge.html @@ -0,0 +1,74 @@ +<%Links::Tools::expired_links_purge%> + + + +Gossamer Links - Tools - Purge Expired Links + + + + + + +
        + + + + + + + +
        Purge Expired Links
        +

        Purge Expired Links

        + <%if message%> +

        Results: <%message%>

        + <%endif%> + <%if error%> +

        Error: <%error%>

        + <%endif%> +

        This allows you to purge links that have expired within a certain number of days. +  

        +
        + +
        +
        + + +
        + + + + + + + + +
        Purge Expired Links:
        + + Number of Days: + + + + +
        +
        +
        + + +
        + + + + +
        + + + +
        +
        + + + +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_module_env.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_module_env.html new file mode 100644 index 0000000..1f0b629 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_module_env.html @@ -0,0 +1,73 @@ + + + + + + Gossamer Links: Module Environment + <%include include_style.html%> + + + + + +<%set header_title = 'Module Environment'%> +<%set header_subtitle = $header_title%> +<%set header_details = 'Modules/files loaded into current process (PID '%> +<%set header_details .= $current_pid%> +<%set header_details .= ')'%> +<%include include_header.html%> + + + + + + + + +<%loop modules%> + + + <%if file_type eq 'file'%> + + + <%else%> + + <%if module_version%><%else%><%endif%> + <%endif%> + +<%endloop%> + +
        File loadedModule loadedModule version
        <%inc_path%>N/AN/A<%module%><%module_version%>none
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_mysqlman.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_mysqlman.html new file mode 100644 index 0000000..6f29ad1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_mysqlman.html @@ -0,0 +1,31 @@ +<%Links::SQL::load%> + + + +Gossamer Links - Tools - Status + + + + + +<%Links::header ('MySQLMan', 'An SQL utility for MySQL')%> + +
        + +
        + + +
        + + Warning: MySQLMan is a low level SQL utility. Improper usage can destroy your Gossamer Links installation.

        + + Launch MySQLMan

        + + For more information about MySQLMan and what it can do, please visit http://gossamer-threads.com/scripts/mysqlman/ +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_search_logs.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_search_logs.html new file mode 100644 index 0000000..f02ddc7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_search_logs.html @@ -0,0 +1,57 @@ + + + + Gossamer Links - Tools - Keyword Searches + <%include include_style.html%> + + + + + +<%set header_title = 'Search Query Logs'%> +<%set header_details = 'This screen shows you a list of search queries people have performed.'%> +<%unless config.search_logging%><%set header_details .= "

        Note: Search Logs are currently disabled. You can enable Search Logs from the Setup => Search Options page."%><%endif%> +<%include include_header.html%> + +<%Links::Tools::search_log%> +
        + +<%if toolbar%> +
        Pages: <%toolbar%>
        +<%endif%> + + + + + + + + + + +<%loop log_loop%> + + + + + + + +<%endloop%> +
        QueryCountLast SearchedResultsAvg. Time Elapsed
        <%escape_html slog_query%><%slog_count%><%GT::Date::date_get($slog_last, '%yyyy%-%mm%-%dd% %h%:%MM% %tt%')%><%slog_hits%><%if slog_time%><%slog_time_formatted%><%else%>Unknown<%endif%>
        + +<%if toolbar%> +
        Pages: <%toolbar%>
        +<%endif%> + +
        +
        + Purge listings older than days old. + + + +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_sql_monitor.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_sql_monitor.html new file mode 100644 index 0000000..633e920 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_sql_monitor.html @@ -0,0 +1,58 @@ +<%Links::Tools::sql_monitor%> + + + +Gossamer Links - Tools - SQL Monitor + + + + + +<%Links::header('SQL Monitor', 'This lets you send queries directly to your SQL server. If you are using MySQL as your database, you can use MySQLMan for more robust SQL management.')%> + +
        +
        + + + +
        + + +
        + + Please enter your query (Gossamer Links tables are <%if db_prefix%>prefixed with '<%db_prefix%>'<%else%>not prefixed<%endif%>): +

        +
        + <%if query and not error%> + + Last query:
        <%escape_html query%>

        + <%endif%> + Save output to file: (leave blank to output to screen)
        + Output format: checked<%endif%>> Tab-separated values checked<%endif%>> Text checked<%endif%>> HTML
        +
        + +
        +
        +
        +
        + +<%if error%> +

        Error: + <%if error_connect%>Could not connect to database: <%escape_html error_connect%><%endif%> + <%if error_prepare%>Could not prepare query: <%escape_html error_prepare%><%endif%> + <%if error_execute%>Could not execute query: <%escape_html error_execute%><%endif%> + <%if error_other%><%escape_html error_other%><%endif%> +

        +<%endif%> + +<%if results%> + <%unless results starts "Rows affected"%>

        Your query returned <%rows%> rows.

        <%endunless%> + <%results%> +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_status.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_status.html new file mode 100644 index 0000000..cea0f9e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_status.html @@ -0,0 +1,76 @@ +<%Links::Tools::status%> + + + +Gossamer Links - Tools - Status + + + + + + +
        + + + + + + + +
        Link + Status
        +

        Link + Status

        +

        From here you can quickly scan your links + database and prune out links that are no longer valid. You can view a full history of whether + a link has been active or not before deciding to delete it.

        +
        + +
        +
        + + + +
        + + +
        + +

        Display links that are:

        + + + + + + + + + +
        + +   + Good: <%Good%> +   +   Bad: + <%Bad%> +   + New: <%New%>  + Total: <%All%>
        + +

        Or click on one of the status + codes below to view all links that have that status code.

        + + + + + +<%Status%> +
        NumberStatus
        + +

        +
        +
        +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate.html new file mode 100644 index 0000000..1d9a0a5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate.html @@ -0,0 +1,167 @@ +<%Links::Tools::validate_links%> + + + +Gossamer Links - Tools - Validate Records + + + + + + + +
        + + + + + + + +
        Validate Records
        +

        Validate Records

        +

        This allows you to validate links that users + have suggested. +<%if results%> +

        <%results%>

        +<%endif%> +

        There are <%total%> links waiting to be validated.

        +
        + +<%if total%> +
        +
        + + + +
        +
        + + + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> - + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +<%output%> + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +
        +
        +
        +
        + +
        +<%endif%> + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_changes.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_changes.html new file mode 100644 index 0000000..93052c9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_changes.html @@ -0,0 +1,170 @@ +<%Links::Tools::validate_changes%> + + + +Gossamer Links - Tools - Validate Records + + + + + + + +
        + + + + + + + +
        Validate Changes
        +

        Validate Changes

        +

        This allows you to validate changes that users have requested.

        +

        For columns that have been modified, you can view the original contents of the field by clicking on the column name.

        +<%if results%> +

        <%results%>

        +<%endif%> +

        There are <%total%> links waiting to be validated.

        +
        + +<%if total%> +
        +
        + + + +
        +
        + + + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> - + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +<%output%> + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +
        +
        +
        +
        + +
        +<%endif%> + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_reviews.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_reviews.html new file mode 100644 index 0000000..260d05c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_validate_reviews.html @@ -0,0 +1,167 @@ +<%Links::Tools::validate_reviews%> + + + +Gossamer Links - Tools - Validate Reviews + + + + + + + +
        + + + + + + + +
        Validate Reviews
        +

        Validate Reviews

        +

        This allows you to validate reviews that users + have entered. +<%if results%> +

        <%results%>

        +<%endif%> +

        There are <%total%> reviews waiting to be validated.

        +
        + +<%if total%> +
        +
        + + + +
        +
        + + + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> - + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +<%output%> + +<%if total > 1%> + + +
        + + +
        +

        + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> + Links per page: + + +

        +

        + + + +

        +
        +
        +<%endif%> + +
        +
        +
        +
        + +
        +<%endif%> + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_verify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_verify.html new file mode 100644 index 0000000..c7ac183 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_verify.html @@ -0,0 +1,88 @@ +<%Links::Tools::status%> + + + +Gossamer Links - Tools - Status + + + + + + +
        + + + + + + + +
        Link + Status
        +

        Link + Status

        +

        This allows you to go + and check the status of links in your database. Please note: for very + large databases, you will need to run nph-verify.cgi from telnet and + not from the web. It is recommended that you setup your system to run + nph-verify.cgi nightly to automatically check links that haven't been + checked in 7 days.

        +
        + +
        +
        + +
        + + +
        + + + + + + + + + + + +
        + + Link Status: +
        + +  Good: <%Good%>   +   Bad: + <%Bad%> +  New: <%New%> Total: <%All%>
        +

        Verify links that:

        +

        + Haven't been checked for days
        + Haven't been checked between + and
        + Recheck problem links
        + Unchecked links
        + With status code
        + Everything

        +

        Verify Link Settings:

        +

        + The maximum number of processes created to verify links. Raising + this value will increase the speed to verify links, but may put more + strain on your server. The default is set to 3, but the previous + default value of 10 may also work well.
        + max_children
        +
        + The number of links each child process should check. Lowering this + value may help maximize the number of children working at the end + of the verification process.
        + chunk
        +

        +

        +
        +
        + +
        + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_view_status.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_view_status.html new file mode 100644 index 0000000..0c13b7e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/tools_view_status.html @@ -0,0 +1,63 @@ +<%Links::Tools::view_status%> + + + +Gossamer Links - Tools - View Status + + + + + + +
        + + + + + + + +
        View Link + Status
        +

        View + Link Status

        +

        This allows you to view the status of + links quickly, removing ones that are no longer valid. +

        Your search returned <%total%> links.

        +
        + +<%if total%> +
        +
        + + + + +
        + +<%if toolbar%> + +<%endif%> + +<%output%> + +<%if toolbar%> + +<%endif%> +
        +

        Pages: <%toolbar%>

        +
        +

        Pages: <%toolbar%>

        +
        +
        + +
        +
        +
        +
        + +
        +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update.html new file mode 100644 index 0000000..74ff0cb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update.html @@ -0,0 +1,15 @@ + + + + Gossamer Links - Update + + + + + + <body bgcolor="#ffffff"> + <p>Gossamer Links requires a frames-compatible browser.</p> + </body> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_available.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_available.html new file mode 100644 index 0000000..4a08943 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_available.html @@ -0,0 +1,36 @@ + + +<%Links::Update::check%> + + + + Available Updates + + +<%if error%> +
        <%error%>
        +<%else%> +

        + <%critical_installable%> critical update(s) available. +

        + +

        + <%optional_installable%> optional update(s) available. +

        +

        + <%version_installable%> new version is available for download. +

        +

        + Total updates available: + <%~set total = $critical_installable%> + <%~set total += $recommended_installable%> + <%~set total += $optional_installable%> + <%~set total += $version_installable%> + <%~total~%> + +

        +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_cat_tree.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_cat_tree.html new file mode 100644 index 0000000..c5bedab --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_cat_tree.html @@ -0,0 +1,36 @@ + + + + + Gossamer Links - Updates - Rebuild Category Tree + <%include include_style.html%> + + + + + <%set header_title = 'Rebuild Category Tree'~%> + <%set header_subtitle = 'Rebuild Gossamer Links Category Tree'%> + + <%if not in.confirm~%> + <%set header_details = "This page allows you to rebuild the Gossamer Links category tree.

        + + Performing this action is strongly discouraged unless advised by Gossamer Threads support staff.

        + + If a Gossamer Threads support staff has advised you to do so, + click here + to rebuild the category tree. + "~%> + <%else~%> + <%set header_details = ''~%> + <%endif~%> + <%include include_header.html%> + + +<%if in.confirm%> +
        +<%Links::Upgrade::browser_cat_tree('force')%>
        +
        +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_display.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_display.html new file mode 100644 index 0000000..d6f960a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_display.html @@ -0,0 +1,89 @@ + + + + +
        + +
        + <%~set show_check = 1%> + <%~if update_mode eq 'history' and not reversible%> + <%~set show_check = 0%> + <%~elsif deps_first or revdeps_first%> + <%~set show_check = 0%> + <%~endif%> + <%if show_check~%> + + <%~endif%> +
        <%if show_check%><%endif%>
        +
        <%if show_check%><%else%><%title%><%endif%>
        +
        Show details
        +
        +
        + <%if installed~%> +
        Installed: <%GT::Date::date_get($installed, '%yyyy%-%mm%-%dd% %HH%:%mm%:%ss%')%>
        + <%~endif%> +
        <%description%>
        + <%if not historic_version or historic_version eq $current_version%> + <%if reversible%>
        This update can be uninstalled.
        + <%else%> +
        + <%if irreversible_dep~%> + This update cannot be uninstalled because another, uninstallable update depends on it. + <%~else~%> + This update cannot be uninstalled. + <%~endif%> +
        + <%endif~%> + <%endif~%> + <%set display_files = 0~%> + <%if files.length~%> + <%loop files%><%unless id eq 'code'%><%set display_files = 1%><%lastloop%><%endunless%><%endloop%> + <%~endif%> + + <%if deps_first and requires.length~%> +
        + This update requires the following updates to be installed prior to installation: +
          + <%~loop requires%> +
        • <%ucfirst update.$loop_value.update_type%> update: <%update.$loop_value.title%>
        • + <%~endloop%> +
        +
        + <%~elsif revdeps_first and revdeps.length%> +
        + This update requires the following updates to be uninstalled prior to being removed: +
          + <%~loop revdeps%> +
        • <%ucfirst update.$loop_value.update_type%> update: <%update.$loop_value.title%>
        • + <%~endloop%> +
        +
        + <%~endif%> + + <%if display_files~%> +
        + Files contained in update: + <%if update_mode eq 'history' and reversible~%> + (* = original file will be restored) + <%~endif%> + + + + + + + <%~loop files%> + <%~if id eq 'code'%><%nextloop%><%endif%> + + + + + + <%~endloop%> +
        FileTypePermission
        <%Links::Update::shorten($path, 8, 50)%><%if update_mode eq 'history' and backup%> *<%endif%><%if dir%>directory<%else%>file<%endif%><%mode%>
        +
        + <%~endif%> +
        +
        diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_history.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_history.html new file mode 100644 index 0000000..467516b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_history.html @@ -0,0 +1,72 @@ + +<%if uninstall~%> + <%Links::Update::browser_uninstall~%> + <%if uninstall_success%><%set message = 'Selected updates have been successfully uninstalled.'%><%endif~%> +<%endif~%> +<%if not config.reg_number%> +<%set error = "You must enter a valid registration number before checking for updates. You can enter a registration number in the Setup -> Misc. Options menu."%> +<%else%> +<%Links::Update::check_historic($historic_version)~%> +<%endif%> + +<%set update_mode = 'history'~%> + + + + Gossamer Links - Updates - Installed Updates + <%include include_style.html%> + <%include update_style.html%> + <%include update_js.html%> + + + +
        +

        Update History

        +

        Gossamer Links Update History

        + <%if message%>
        Results: 
        <%message%>
        <%endif%> + <%if error%>
        Error: 
        <%error%>
        <%endif%> + +
        This page lists the currently installed Gossamer Links updates, and allows + you to uninstall updates. Note that some updates cannot be uninstalled. +

        + +<%set any_updates_shown = 0%> +<%~loop update_types%><%loop updates%><%if installed%><%set any_updates_shown = 1%><%lastloop%><%endloop%><%endloop%> +<%if any_updates_shown%> +
        Show all details
        + +<%endif%> + + <%if historic.length > 1~%> + Older version update history: + <%~loop historic%> + <%~if loop_value eq $historic_version%> <%loop_value%> + <%~else%> <%loop_value%> + <%~endif%> + <%~endloop%> + <%~else%> <%endif%> +
        +
        + +
        + + +<%if updates_selected~%> + +<%endif~%> +
        +<%~loop update_types%> +<%~loop updates%> +<%~unless installed%><%nextloop%><%endif%> +<%include update_display.html%> +<%endloop~%> +<%endloop~%> +
        + + + +
        + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_install.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_install.html new file mode 100644 index 0000000..d967da1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_install.html @@ -0,0 +1,20 @@ + +<%Links::Update::browser_install%> +<%if update_failed%><%include update_list.html%><%endparse%> +<%else%><%set success_message = 'Updates installed successfully'%> +<%endif%> + + + Gossamer Links - Updates - Install Updates + <%include include_style.html%> + + + + +<%set header_title = 'Update installation successful'%> +<%set header_subtitle = 'Update installation successful'%> +<%set header_details = 'The select update(s) have been successfully installed.'%> +<%include include_header.html%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_js.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_js.html new file mode 100644 index 0000000..6f97c6f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_js.html @@ -0,0 +1,205 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_list.html new file mode 100644 index 0000000..917b248 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_list.html @@ -0,0 +1,115 @@ + +<%if install~%> + <%Links::Update::browser_install~%> + <%if update_success and update_status == 2~%><%include update_version.html%><%endparse~%> + <%elsif update_success%><%set message = 'Selected updates have been successfully installed.'~%> + <%elsif update_failed~%> + <%if verify_failed~%> + <%set error = "Unable to installed selected updates: Update verification failed: "~%> + <%set failure_reason = '
          '~%> + <%if already_installed%><%set failure_reason .= "
        • Some selected updates were already installed.
        • "~%> + <%elsif does_not_exist%><%set failure_reason .= "
        • Some selected updates are no longer available for installation.
        • "~%> + <%elsif unique_update%><%set failure_reason .= "
        • One or more selected updates are marked as unique, but more than one update was selected.
        • "~%> + <%elsif depends_on%><%set failure_reason .= "
        • One or more selected updates require dependencies which were not selected.
        • "~%> + <%endif~%> + <%if failure_reason eq '
            '%><%set failure_reason = 'Unknown error.'%><%else%><%set failure_reason .= '
          '%><%endif~%> + <%set error .= $failure_reason~%> + <%endif~%> + <%endif~%> +<%endif~%> +<%if not config.reg_number~%> +<%set error = "You must enter a valid registration number before checking for updates. You can enter a registration number in the Setup -> Misc. Options menu."~%> +<%else~%> +<%Links::Update::check~%> + +<%endif~%> + +<%if error and update_error_code~%> + <%if update_error_code == 203~%> + <%set error .= "

          You can reset the admin path stored on the Gossamer Threads update server a limited number of times from the licensed download area."~%> + <%endif~%> +<%endif~%> + +<%set update_mode = 'install'~%> + + + + Gossamer Links - Updates - Available Updates + <%include include_style.html%> + <%include update_style.html%> + <%include update_js.html%> + + + +
          +

          Available Updates

          +

          Available Updates

          + <%if message%>
          Results: 
          <%message%>
          <%endif%> + <%if error%>
          Error: 
          <%error%>
          <%endif%> +

          + + The following updates are available for your Gossamer Links installation:

          + + + <%if critical_installable%> + <%critical_installable%> critical update<%unless critical_installable == 1%>s<%endunless%> + <%else%> + No critical updates + <%endif%> + +
          + + + <%if recommended_installable%> + <%recommended_installable%> recommended update<%unless recommended_installable == 1%>s<%endunless%> + <%else%> + No recommended updates + <%endif%> + +
          + + + <%if optional_installable%> + <%optional_installable%> optional update<%unless optional_installable == 1%>s<%endunless%> + <%else%> + No optional updates + <%endif%> + +
          + + <%if critical_installable or recommended_installable or optional_installable or version_installable%> +
          Show all details
          + + <%endif%> + + + <%if version_installable%> + A new version is available! + <%else%> + No new version is available. + <%endif%> + +

          +
          + + +
          + + +<%if updates_selected%><%endif%> +
          +<%loop update_types%> +<%loop updates%> +<%if installed or impossible%><%nextloop%><%endif%> +<%include update_display.html%> +<%endloop%> +<%endloop%> +
          + + +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_nav.html new file mode 100644 index 0000000..754e270 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_nav.html @@ -0,0 +1,33 @@ + + + + Gossamer Links - Updates + <%include include_style.html%> + + + + +
          +

          Updates

          + + +<%if config.show_upgrade_rerun%> +

          Re-run upgrade

          +<%~Links::Upgrade::upgrades_available()%> + + +

          Rebuild

          + +<%endif%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_rerun.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_rerun.html new file mode 100644 index 0000000..d97cb56 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_rerun.html @@ -0,0 +1,38 @@ + + + + + Gossamer Links - Updates - Re-run upgrade + <%include include_style.html%> + + + + + <%set header_title = 'Re-run Upgrade'~%> + <%set header_subtitle = "Re-run ${in.version} -> ${config.version} upgrade code~%> + + <%if in.version and not in.confirm~%> + <%set header_details = "This page allows you to re-run the ${in.version} -> ${config.version} upgrade code.

          + + Re-running this upgrade code is not recommended unless advised by Gossamer Threads support staff.

          + + If a Gossamer Threads support staff member has advised you to do so, + click here + to run the upgrade code. + "~%> + <%else~%> + <%set header_details = ''~%> + <%endif~%> + <%include include_header.html%> + + +<%if in.version and in.confirm%> +
          +
          +
          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_style.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_style.html new file mode 100644 index 0000000..3016895 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_style.html @@ -0,0 +1,145 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_version.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_version.html new file mode 100644 index 0000000..7bf4358 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/update_version.html @@ -0,0 +1,18 @@ + + + + + Gossamer Links - Updates - New version update + <%include include_style.html%> + + + + + <%set header_title = "Available Updates"~%> + <%set header_subtitle = "New version installation"~%> + <%set message = "Gossamer Links upgrade files have been downloaded."~%> + <%set header_details = "Please click here to continue with the program upgrade."~%> + <%include include_header.html%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_add.html new file mode 100644 index 0000000..9b845b1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_add.html @@ -0,0 +1,181 @@ + + + + <%include widget_css.html%> + + + +
          +

          <%if in.ID%>Modify<%else%>Add<%endif%> Widget

          +
          +
          + <%~if error%>

          <%error%>

          <%endif%> +
          + + + + + + +
          +
          +
          Type
          +
          +
          + +
          +
          +
          +
          Widget
          +
          +
          + +
          +
          +
          +
          Title
          +
          +
          +
          +
          +
          Title's CSS
          +
          +
          + +
          E.g.: color: #ffffff; background: #000000; +
          +
          +
          +
          Sub-title/Content
          +
          +
          + +
          +
          +
          +
          List ID
          +
          +
          +
          +
          +
          Image
          +
          +
          +
          +
          +
          URL
          +
          +
          +
          +
          +
          Button
          +
          +
          +
          +
          +
          Forum
          +
          +
          + +
          +
          +
          +
          Articles/Threads
          (Use comma to separate IDs)
          +
          +
          disabled<%endif%>/>
          +
          +
          +
          Category
          +
          +
          + <%~set categories_loop = Plugins::Widgets::fetch_categories%> + +
          +
          +
          +
          +
          +
          +
          +
          +
          +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_css.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_css.html new file mode 100644 index 0000000..00424a9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widget_css.html @@ -0,0 +1,160 @@ +<%site_title || 'Slowtwitch.com'%> + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgetlink_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgetlink_add.html new file mode 100644 index 0000000..67b124e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgetlink_add.html @@ -0,0 +1,98 @@ + + + + <%include widget_css.html%> + + + +
          +

          <%if in.ID%>Modify<%else%>Add<%endif%> External Links Widget

          +
          +
          + <%~if error%>

          <%error%>

          <%endif%> + <%~set NumLinks = 15%> +
          + + + + + + + + + +
          +
          +
          Title
          +
          +
          +
          +
          +
          Styling CSS
          +
          +
          + +
          E.g.: color: #ffffff; background: #000000; +
          +
          +
          +
          Links
          +
          +
          +
          +
           
          +
          Link
          +
          Abstracts
          +
          URL
          +
          + <%loop 1 .. $NumLinks%> + +
          +
          <%row_num%>.
          +
          +
          +
          +
          + <%endloop%> +
          + Note: Empty link's title to remove a link. +
          +
          +
          +
          +
          +
          +
          +
          +
          +
          +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgets.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgets.html new file mode 100644 index 0000000..9fbbc66 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/admin/widgets.html @@ -0,0 +1,146 @@ + + + + <%include widget_css.html%> + + + +
          +

          Widgets Management

          + Add External Links Widget + Add Widget +
          +
          +

          <%success || ''%>

          +
          + + + + + +
          + +
          + <%set categories_loop = Plugins::Widgets::fetch_categories()%> + +
          +
          +
          +
          +
          +

          Available Widgets

          +
          + <%~loop widgets.available%> +
          + <%~if Type%> + <%include _widget_automated.html%> + <%~else%> + <%include _widget_manual.html%> + <%~endif%> + <%include _widget_pages.html%> +
          + <%~endloop%> +
          + <%~if in.page%> +
          +

          Selected Widgets

          +
          + <%if widgets.selected.length%> + <%~set no_links = 1%> + <%~loop widgets.selected%> +
          + <%~if Type%> + <%include _widget_automated.html%> + <%~else%> + <%include _widget_manual.html%> + <%~endif%> + <%include _widget_pages.html%> +
          + <%~endloop%> + <%~else%> +

          No widget was selected for this page/category

          + <%~endif%> +
          + <%~endif%> +
          +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser.html new file mode 100644 index 0000000..ba55071 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser.html @@ -0,0 +1,1234 @@ + + + + + + Gossamer Links + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category.html new file mode 100644 index 0000000..6129420 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category.html @@ -0,0 +1,41 @@ + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links<%if config.payment.enabled%> (titles coloured red are links still awaiting payment or have expired)<%endif%>.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add.html new file mode 100644 index 0000000..67a39b5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add.html @@ -0,0 +1,67 @@ + + + + + + + + +
          + + + + + + + +
          +Browse Category: <%parent_name%> +
          +

          +Browse Category: <%parent_name%>
          + +Category <%child_name%> added successfully. + +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add_form.html new file mode 100644 index 0000000..c74064e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_add_form.html @@ -0,0 +1,45 @@ + + + Add a sub-category + + + + + +
          + + + + + + + +
          +Add a Sub Category beneath <%Name%> +
          +

          +Add a Sub Category beneath <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          + +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST" onSubmit="parent.CAN_UPDATE=1;"> + + <%form%> + +
          + +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del.html new file mode 100644 index 0000000..2397ded --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del.html @@ -0,0 +1,70 @@ + + + + + + + + +
          + + + + + + + +
          +Browse Category: <%father_name%> +
          +

          +Browse Category: <%father_name%>
          +<%child_name%> has been deleted. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del_form.html new file mode 100644 index 0000000..6110f21 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_del_form.html @@ -0,0 +1,31 @@ + + + + +
          + + + + + + + +
          +Delete Category: <%Name%> +
          +

          +Delete Category: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          Are you sure that you want to delete category "<%Name%>" (<%category_id%>)? Note that this will also remove all links in this category. +

          +     + Yes     No + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_form.html new file mode 100644 index 0000000..085a797 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_form.html @@ -0,0 +1,80 @@ + + + + + + + +
          + + + + + + + +
          +Set Editors for Category: <%Name%> +
          +

          +Set Editors for Category: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST"> + + + +<%if editors%> +

          The following users have editor access to this area:

          +<%editors%> +

          +<%endif%> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Add New + Editor:
          Username:
          Permissions:
          CategoriesAdd + Delete Modify + Move Relations
          LinksAdd + Delete Modify + Copy Move + Validate
          ReviewsDelete/Modify/Validate
          EditorsAdd
          +

          + + +

           

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_row.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_row.html new file mode 100644 index 0000000..4c3ac91 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_editors_row.html @@ -0,0 +1,21 @@ +
        • <%Username%> (<%Full_Name%>)
          +Permissions:
          +Links: +<%if CanAddLink eq 'Yes'%>Add<%endif%> +<%if CanDelLink eq 'Yes'%>Delete<%endif%> +<%if CanModLink eq 'Yes'%>Modify<%endif%> +<%if CanMoveLink eq 'Yes'%>Move<%endif%> +<%if CanCopyLink eq 'Yes'%>Copy<%endif%> +<%if CanValLink eq 'Yes'%>Validate<%endif%> +Category: +<%if CanAddCat eq 'Yes'%>Add<%endif%> +<%if CanDelCat eq 'Yes'%>Delete<%endif%> +<%if CanModCat eq 'Yes'%>Modify<%endif%> +<%if CanMoveCat eq 'Yes'%>Move<%endif%> +<%if CanAddRel eq 'Yes'%>Related<%endif%> +Reviews: +<%if CanModReview eq 'Yes'%>Delete/Modify/Validate<%endif%> +Editors: +<%if CanAddEdit eq 'Yes'%>Add<%endif%> +
          +
        • diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_expand.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_expand.html new file mode 100644 index 0000000..1e2a5f3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_expand.html @@ -0,0 +1,13 @@ + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify.html new file mode 100644 index 0000000..68a62ec --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify.html @@ -0,0 +1,65 @@ + + + + + + + + +
          + + + + + + + +
          +Browse Category: <%Name%> +
          +

          +Browse Category: <%Name%>
          +<%Name%> has been successfully modified. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify_form.html new file mode 100644 index 0000000..d70234b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_modify_form.html @@ -0,0 +1,39 @@ + + + + +
          + + + + + + + +
          +Modify Category: <%Name%> +
          +

          +Modify Category: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" onSubmit="parent.CAN_UPDATE = 1;" method="POST"> + + <%form%> + +
          +
          +
          +
          + +

          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move.html new file mode 100644 index 0000000..7319520 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move.html @@ -0,0 +1,121 @@ + + + + + + + +
          + + + + + + + +
          +Browse Category: <%Name%> +
          +

          +Browse Category: <%Name%>
          +<%Name%> has been successfully moved. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move_form.html new file mode 100644 index 0000000..e61c899 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_move_form.html @@ -0,0 +1,39 @@ + + + + + + + + +
          + + + + + + + +
          +Move Category: <%Name%> +
          +

          +Move Category: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          Please use the tree on your left to pick the category in + which you want to move the current category to, or + Click here to cancel +

          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_related_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_related_form.html new file mode 100644 index 0000000..3b4db34 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_category_related_form.html @@ -0,0 +1,51 @@ + + + + + + + + +
          + + + + + + + +
          +Set Related Categories for: <%Name%> +
          +

          +Set Related Categories for: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +
          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST" name="related_form"> + + + + +<%if related%> +

          The following categories are already related:

          +<%related%> +<%endif%> +

          To create a related category, enter in the name you would like to appear (or leave blank +for the default), and then click on the category you want to <%Name%> to be related to. +

          Relation Name: + +

          Click here when finished. + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_code_init.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_code_init.html new file mode 100644 index 0000000..42ca491 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_code_init.html @@ -0,0 +1,14 @@ + + + + + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_info.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_info.html new file mode 100644 index 0000000..9e8168c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_info.html @@ -0,0 +1,25 @@ + + + + + + + +
          +

          Browse

          +
          +

          New to Gossamer Links is + our Category Management tool. From here, you can visually see the + layout of your categories, and point and click to move entire sections + of your category structure. You can also use it to add/modify/delete + links, and add/modify/delete categories. If you are looking for a + specific link or category, you should use the Database tool to do a + search.

          +

          For large category + structures, the tree only loads the parts you ask for, thus making + category management much easier, or if you prefer, there are links to + load the entire tree as well.

          +

           

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_javascript_error.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_javascript_error.html new file mode 100644 index 0000000..11dccbf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_javascript_error.html @@ -0,0 +1,10 @@ + + + Error + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add.html new file mode 100644 index 0000000..f8ff9b2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add.html @@ -0,0 +1,72 @@ + + + + + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          +Link added successfully to <%Name%>. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add_form.html new file mode 100644 index 0000000..1a87799 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_add_form.html @@ -0,0 +1,39 @@ + + + + +
          + + + + + + + +
          +Add Link to: <%Name%> +
          +

          +Add Link to: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST" onSubmit="parent.CAN_UPDATE = 1;"> + + <%form%> + +
          +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy.html new file mode 100644 index 0000000..f5187d0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy.html @@ -0,0 +1,73 @@ + + + + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          +Link successfully copied to <%New_Name%>. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy_form.html new file mode 100644 index 0000000..262a247 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_copy_form.html @@ -0,0 +1,41 @@ + + + + + + + +
          + + + + + + + +
          +Copy Link From: <%Name%> +
          +

          +Copy Link From: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          Please use the tree on your left to pick the category in + which you want to copy the selected link or + Click here to cancel +

          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del.html new file mode 100644 index 0000000..e7ebcf6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del.html @@ -0,0 +1,71 @@ + + + + + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          +Link successfully deleted. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del_form.html new file mode 100644 index 0000000..759ed52 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_del_form.html @@ -0,0 +1,31 @@ + + + +
          + + + + + + + +
          +Delete Link <%link%> from <%Name%> +
          +

          +Delete Link <%link%> from <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + + +

          Are you sure that you want to delete the link "<%link%>" (<%link_id%>)? +

          +   Yes +   No +

          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_list.html new file mode 100644 index 0000000..b37bef0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_list.html @@ -0,0 +1,22 @@ + + +
        • <%if ExpiryDate < $TIME%><%endif%><%escape_html Title%><%if ExpiryDate < $TIME%><%endif%>
        • + + + <%escape_html URL%> + + + <%if isValidated eq 'No'%> + <%if CanValLink eq 'Yes'%>Validate | <%endif%> + <%endif%> + <%if hasChangeRequest%> + <%if CanValLink eq 'Yes'%>Validate Changes | <%endif%> + <%endif%> + <%if CanModLink eq 'Yes'%>Edit | <%endif%> + <%if CanDelLink eq 'Yes'%>Delete | <%endif%> + <%if CanMoveLink eq 'Yes'%>Move | <%endif%> + <%if CanCopyLink eq 'Yes'%>Copy | <%endif%> + Owner + <%if CanModReview eq 'Yes' and hasReviews%>| Reviews<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify.html new file mode 100644 index 0000000..91044ff --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify.html @@ -0,0 +1,42 @@ + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          +Link modified successfully. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify_form.html new file mode 100644 index 0000000..ce67af4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_modify_form.html @@ -0,0 +1,55 @@ + + + + +
          + + + + + + + +
          +Modify Link in: <%Name%> +
          +

          +Modify Link in: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST"> + + + <%form%> + +
          + <%if category_loop.length%> + <%Links::config_vars%> +
          +
          + This link is in the following categories: +
          + <%loop category_loop%> +
        • <%Full_Name%> + <%endloop%> +
        • +
          +
          +
          + <%endif%> + +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move.html new file mode 100644 index 0000000..831ff36 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move.html @@ -0,0 +1,89 @@ + + + + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          +Link successfully moved to <%New_Name%>. +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move_form.html new file mode 100644 index 0000000..2c927f5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_move_form.html @@ -0,0 +1,39 @@ + + + + + + + +
          + + + + + + + +
          +Move Link From: <%Name%> +
          +

          +Move Link From: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          Please use the tree on your left to pick the category in + which you want to move the selected link or Click here to cancel +

          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_owner.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_owner.html new file mode 100644 index 0000000..fe13205 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_owner.html @@ -0,0 +1,46 @@ + + + + +
          + + + + + + + +
          +Browse Links Owned by: <%link_owner%> +
          +

          +Browse Links Owned by: <%Username%> +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          <%Username%> owns the following <%count%> links.
          +<%endif%> +<%ifnot links%> + + +
          <%Username%> does not own any links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_form.html new file mode 100644 index 0000000..02aed6b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_form.html @@ -0,0 +1,82 @@ + + + + +
          + + + + + + + +
          +Search Links +
          +

          +Search Links +

          +

          +<%navbar%> +

          +
          +
          + +<%error%> +

          +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST" onSubmit="parent.CAN_UPDATE = 1;"> + + <%form%> + +
          +
          +
          + Search only within this category
          +
          + +
          + + +
          + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Maximum Hits:Match Any:
          Keyword Search:
          Indexed Search:
          Sort By: +Using: +
          Display Records: +
          +
          + +
          +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_results.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_results.html new file mode 100644 index 0000000..ce59257 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_search_results.html @@ -0,0 +1,44 @@ + + + + +
          + + + + + + + +
          +Search Results +
          +

          +Search Results +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%loop links%> + <%set category_id = $CategoryID%> + <%include browser_link_list.html%> + <%endloop%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate.html new file mode 100644 index 0000000..737eb1f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate.html @@ -0,0 +1,91 @@ + +<%if action eq 'validate'%> + <%ifnot error%> + + <%endif%> +<%endif%> + + + + + + +
          + + + + + + + +
          +Browse: <%Name%> +
          +

          +Browse: <%Name%>
          + +<%if error%> +Error: <%error%> +<%endif%> +<%ifnot error%> + <%if action eq 'validate'%> + Link successfully validated. + <%endif%> + <%if action eq 'email'%> + Link has been removed, and rejection email sent. + <%endif%> + <%if action eq 'delete'%> + Link has been deleted. + <%endif%> +<%endif%> + +

          +

          +<%navbar%> +

          +
          +
          + +
          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> links.
          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate_form.html new file mode 100644 index 0000000..72a484b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_link_validate_form.html @@ -0,0 +1,98 @@ + + + + + + + +
          + + + + + + + +
          +Validate Link in: <%Name%> +
          +

          +Validate Link in: <%Name%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="POST" onSubmit="parent.CAN_UPDATE = 1;"> + + + + + + +
          <%form%>
          +<%ifnot update%> + + + + + + + + +
          + Validate (view) + + + Delete without reason + + + Delete and email reason + +
          + +
          +<%endif%> +<%if update%> + + + + + + + + +
          + Modify (view) + + + Delete Change without reason + + + Delete Change and email reason + +
          + +
          +<%endif%> +
          + +

          + +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_navbar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_navbar.html new file mode 100644 index 0000000..383e63e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_navbar.html @@ -0,0 +1,15 @@ +Browse +<%if CanAddCat eq 'Yes'%> | Add Cat<%endif%> +<%if category_id%> + <%if CanAddLink eq 'Yes'%> | Add Link<%endif%> + <%if CanModCat eq 'Yes'%> | Edit<%endif%> + <%if CanDelCat eq 'Yes'%> | Delete<%endif%> + <%if CanMoveCat eq 'Yes'%> | Move<%endif%> + <%if CanAddEdit eq 'Yes'%> | Editors<%endif%> + <%if CanAddRel eq 'Yes'%> | Related<%endif%> + | Search +<%endif%> +<%if CanValLink eq 'Yes'%> | Validate Links<%endif%> +<%if CanValLink eq 'Yes'%> | Validate Changes<%endif%> +<%if CanModReview eq 'Yes'%> | Validate Reviews<%endif%> +<%if is_admin and CanAddTerms eq 'Yes'%> | Add/Edit Payment Terms<%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_del_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_del_form.html new file mode 100644 index 0000000..17d2078 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_del_form.html @@ -0,0 +1,31 @@ + + + +
          + + + + + + + +
          +Delete Review <%escape_html Review_Subject%> +
          +

          +Delete Review <%escape_html Review_Subject%> +

          +

          +<%navbar%> +

          +
          +
          + + +

          Are you sure that you want to delete the review <%escape_html Review_Subject%>? +

          +   Yes +   No +

          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_list.html new file mode 100644 index 0000000..caecb81 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_list.html @@ -0,0 +1,14 @@ + + + <%escape_html Title%> + + <%escape_html Review_Subject%> + + <%Review_Owner%> + + + Delete + | Modify + <%if Review_Validated eq 'No'%>| Validate<%endif%> + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_modify_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_modify_form.html new file mode 100644 index 0000000..7703796 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_modify_form.html @@ -0,0 +1,73 @@ + + + + +
          + + + + + + + +
          +<%if validate%>Validating<%else%>Modifying<%endif%> Review of: <%escape_html Title%> +
          +

          +<%if validate%>Validating<%else%>Modifying<%endif%> Review of: <%escape_html Title%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          action="<%if is_admin%>admin.cgi<%else%><%db_cgi_url%>/browser.cgi<%endif%>" method="post"> + + <%if validate%> + + <%else%> + + <%endif%> + + + + +<%if validate%> + +<%endif%> +
          <%form%>
          + + + + + + + + +
          + Validate. + + + Delete without reason. + + + Delete and email reason. + +
          + +
          +
          + +

          + +
          +
          +
          + +
          +

          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_result.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_result.html new file mode 100644 index 0000000..2b9d5a9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_review_result.html @@ -0,0 +1,43 @@ + + + + +
          + + + + + + + +
          +<%if validate%>Validate<%elsif delete%>Delete<%else%>Modify<%endif%> Review +
          +

          +<%if validate%>Validate<%elsif delete%>Delete<%else%>Modify<%endif%> Review +

          +

          +<%navbar%> +

          +<%if error%> +

          Error: <%error%>

          +<%else%> +

          + <%if do eq 'modify'%> + The review was successfully modified. + <%elsif do eq 'validate'%> + The review was successfully validated. + <%elsif do eq 'email'%> + The review has been removed, and rejection email sent. + <%elsif do eq 'delete' or delete%> + The review has been deleted. + <%else%> + No action specified. + <%endif%> +

          +<%endif%> +
          +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_reviews.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_reviews.html new file mode 100644 index 0000000..dee7259 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_reviews.html @@ -0,0 +1,67 @@ + + + + +
          + + + + + + + +
          +<%unless link_id%>Validate <%endif%>Reviews +
          +

          +<%unless link_id%>Validate <%endif%>Reviews +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          + + + + <%if mh%><%endif%> + <%if not link_id and category_id != 0%> checked<%endif%>> Only show reviews from this category and <%endif%>Sort reviews by + + + + +

          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + + + + + + + <%links%> +
          <%if link_id%>This link has <%count%> reviews.<%else%>There are <%count%> reviews waiting to be validated.<%endif%>
          LinkReview SubjectReview OwnerActions
          +<%else%> +

          <%if link_id%>This link has no reviews.<%else%>There are no reviews waiting to be validated.<%endif%>

          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_tree.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_tree.html new file mode 100644 index 0000000..4500f5d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_tree.html @@ -0,0 +1,5 @@ + + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed.html new file mode 100644 index 0000000..ec121fc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed.html @@ -0,0 +1,199 @@ + + + + + + + + +
          + + + + + + + +
          +Validate <%unless update%>Links<%else%>Changes<%endunless%> +
          +

          +Validate <%unless update%>Links<%else%>Changes<%endunless%> +

          +

          +<%navbar%> + + <%if result%>

          <%result%>

          <%endif%> + +

          +<%if links%> + There are <%count%> <%unless update%>links<%else%>changes<%endunless%> waiting to be validated<%if config.payment.enabled%> (titles coloured red are links still awaiting payment or have expired)<%endif%>. +<%else%> + There are no <%unless update%>links<%else%>changes<%endunless%> waiting to be validated. +<%endif%> +

          + + +

          +
          +
          + +<%-- Only show the form for validation if there are links to be edited --%> +<%if links%> + +
          + + + + + + +
          + +
          + + + + + +<%if count > 1%> + + +
          + + +
          +

          + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> - + Links per page: + + +

          +

          + + + +

          + +

          + + <%if mh%><%endif%> + <%if category_id != 0%> checked<%endif%>> Only show links from this category and <%endif%>Sort links by + + +

          + +
          +
          +<%endif%> + +<%if links%><%links%><%endif%> + + + +
          + + +
          +

          + Pages: <%if toolbar%><%toolbar%><%else%>1<%endif%> + Links per page: + + +

          +

          + + + +

          +
          +
          + +
          +
          +
          +
          + +
          + +<%-- endif links --%> +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed_form.html new file mode 100644 index 0000000..041a8f7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_detailed_form.html @@ -0,0 +1,51 @@ + + + +
          <%form%>
          +<%ifnot update%> + + + + + + + + +
          + Validate (view) + + + Delete without reason + + + Delete and email reason + +
          + +
          +<%endif%> +<%if update%> + + + + + + + + +
          + Modify (view) + + + Delete Change without reason + + + Delete Change and email reason + +
          + +
          +<%endif%> +
          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_links.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_links.html new file mode 100644 index 0000000..e9a6fea --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/browser_validate_links.html @@ -0,0 +1,63 @@ + + + + +
          + + + + + + + +
          +Validate <%unless update%>Links<%else%>Changes<%endunless%> +
          +

          +Validate <%unless update%>Links<%else%>Changes<%endunless%> +

          +

          +<%navbar%> +

          +
          +
          + +

          +

          + + + + <%if mh%><%endif%> + <%if category_id != 0%> checked<%endif%>> Only show links from this category and <%endif%>Sort links by + + + + +

          + +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> +<%if links%> + + + <%links%> +
          There are <%count%> <%unless update%>links<%else%>changes<%endunless%> waiting to be validated<%if config.payment.enabled%> (titles coloured red are links still awaiting payment or have expired)<%endif%>.
          +<%else%> +

          There are no <%unless update%>links<%else%>changes<%endunless%> waiting to be validated.

          +<%endif%> +<%if toolbar%> +

          Pages: <%toolbar%>

          +<%endif%> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/language.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/language.txt new file mode 100644 index 0000000..924fe71 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/browser/language.txt @@ -0,0 +1,30 @@ +{ + 'BROWSER_CANTMOD' => 'Unable to modify category: %s', + 'BROWSER_CATCANTADD' => 'Unable to add category: %s', + 'BROWSER_CATCANTDEL' => 'Unable to delete category: %s', + 'BROWSER_EDITORADD' => 'Unable to add editor, please make sure %s is a valid user.', + 'BROWSER_EDITORDEL' => 'Unable to delete editor: %s', + 'BROWSER_INVALIDCATID' => 'Invalid category: \'%s\'.', + 'BROWSER_INVALIDLINKID' => 'Invalid link id: %s', + 'BROWSER_INVALIDREVIEWID' => 'Invalid review id: %s', + 'BROWSER_INVALIDUSER' => 'User \'%s\' not found.', + 'BROWSER_LINKCANTADD' => 'Unable to add link: %s', + 'BROWSER_LINKCANTDEL' => 'Unable to delete link: %s', + 'BROWSER_LINKCANTMOD' => 'Unable to modify link: %s', + 'BROWSER_LINKMOVEEXISTS' => 'You cannot move the link to that category, as it is already in that category.', + 'BROWSER_LINKMOVEROOT' => 'Unable to move/copy a link to the root category, please pick a subcategory.', + 'BROWSER_MOVECHILD' => 'Unable to move category into a sub tree of itself.', + 'BROWSER_MOVEDUPE' => 'Unable to move category as a category with the same name already exists.', + 'BROWSER_MOVESELF' => 'You cannot move a category on top of itself.', + 'BROWSER_NOROOT' => 'Invalid Category Root: \'%s\'.', + 'BROWSER_NOSEARCH' => 'Your search did not match any records.', + 'BROWSER_NOTEDITOR' => 'Only category editors may use the browser.', + 'BROWSER_RELADD' => 'Unable to create relation: %s. Check to make sure it isn\'t already related, and that it is a valid category.', + 'BROWSER_REVIEWVALIDATED' => 'The review has already been validated.', + 'BROWSER_UNAUTHORIZED' => 'You are not authorized to perform this action.', + 'BROWSER_VALIDATE_OK' => 'All Links successfully validated/deleted.', + 'BROWSER_VALIDATE_ERROR' => '
            %s
          ', + +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/common b/site/slowtwitch.com/cgi-bin/articles/admin/templates/common new file mode 120000 index 0000000..5ce8686 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/common @@ -0,0 +1 @@ +/var/home/slowtwitch/site/common/templates \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/.tplinfo b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/.tplinfo new file mode 100644 index 0000000..47e1992 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/.tplinfo @@ -0,0 +1,3 @@ +{ + inheritance => '../luna' +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success.html new file mode 120000 index 0000000..7242385 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success.html @@ -0,0 +1 @@ +add_success_publish.html \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success_publish.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success_publish.html new file mode 100644 index 0000000..5c7ba9b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/add_success_publish.html @@ -0,0 +1,195 @@ + + + + <%site_title%>: Publish Link to Social Media +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +<%if success%> +

          Link Published to Social Media

          +<%else%> +

          Publish Link to Social Media

          +<%endif%> + +<%set ID ||= 4031%> +<%Plugins::SocialMedia::format_link($ID)%> +<%-- + +--%> +<%if success%> + +The build is successful!

          + +<%if twitter_published%>It has been published to twitter.<%elsif twitter_published_message%>There is an error posting twitter: <%twitter_published_message%><%endif%> +

          +<%if facebook_published%>It has been published to facebook.<%elsif facebook_published_message%>There is an error posting facebook: <%facebook_published_message%><%endif%> +

          + +<%else%> + +

          + The following link has been created: +

          + +
          + +
          <%Title%>
          +
          +
          + +
          +<%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          +<%~else%> + <%Category%> +<%~endif%> +
          +
          +
          + +
          <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%>
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +

          +<%~if config.build_auto_validate%> + Your link has been added to <%if Category_loop.length > 1%>the following categories: <%loop Category_loop%><%loop_value%><%unless last%>, <%endunless%><%endloop%><%else%><%Category%><%endif%>. + You can preview the link at here. +<%~else%> + Thank you! We will send you an e-mail once your link has been validated. +<%~endif%> +

          + +<%-- +

          Build it?

          +

          +

          +
          + +
          +
          +

          +--%> + +

          Publish it?

          +

          +

          + +
          + +<%-- +
          + +
          + +
          +
          +
          + +
          + +
          +
          +--%> + +
          + +
          + Yes +
          +
          + +
          + +
          + +
          Use existing status line, or update as required. Link URL will be automatically appended to tweet. +
          +
          + +
          + +
          + +
          Please separate each hash tag with comma.
          For example: bike, runner, slowtwitch. +
          +
          + +
          + +
          + Yes +
          +
          +<%-- +
          + +
          +<%loop image_paths.images_loop%> + + +<%endloop%> +
          +
          +--%> + +<%--DUMP image_paths.images_loop--%> + +
          + +
          +
          +

          +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_detailed_article.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_detailed_article.html new file mode 100644 index 0000000..277ea34 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_detailed_article.html @@ -0,0 +1,445 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + + + +<%--Twitter Meta Tags--%> + + + + + +<%if facebook_published_image%> + <%set facebook_image_url = Plugins::SocialMedia::get_path($facebook_published_image)%> + <%if facebook_image_url%> + + + + <%endif%> +<%elsif Image1_thumbnail_path and Image1_largest_path%> + + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> +<%include include_common_head.html%> + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> + +<%--if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          + <%--Hits: <%Hits%>
          --%> + Date: <%Add_Date%>
          + <%--if Add_Date ne $Mod_Date%>Last Changed: <%Mod_Date%>
          <%endif--%> + +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +<%--if Description%>

          <%Description%>

          <%endif--%> + +
          +<%if Image1_medium_path or Paragraph1%> + <%if Image1_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph1%> +
          + <%Paragraph1%> +
          + + <%endif%> +<%endif%> +<%if Image2_medium_path or Paragraph2%> + <%if Image2_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph2%> +
          + <%Paragraph2%> +
          + <%endif%> +<%endif%> +<%if Image3_medium_path or Paragraph3%> + <%if Image3_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph3%> +
          + <%Paragraph3%> +
          + <%endif%> +<%endif%> +<%if Image4_medium_path or Paragraph4%> + <%if Image4_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph4%> +
          + <%Paragraph4%> +
          + <%endif%> +<%endif%> +<%if Image5_medium_path or Paragraph5%> + <%if Image5_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph5%> +
          + <%Paragraph5%> +
          + <%endif%> +<%endif%> +<%if Image6_medium_path or Paragraph6%> + <%if Image6_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph6%> +
          + <%Paragraph6%> +
          + <%endif%> +<%endif%> +<%if Image7_medium_path or Paragraph7%> + <%if Image7_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph7%> +
          + <%Paragraph7%> +
          + <%endif%> +<%endif%> +<%if Image8_medium_path or Paragraph8%> + <%if Image8_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph8%> +
          + <%Paragraph8%> +
          + <%endif%> +<%endif%> +<%if Image9_medium_path or Paragraph9%> + <%if Image9_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph9%> +
          + <%Paragraph9%> +
          + <%endif%> +<%endif%> +<%if Image10_medium_path or Paragraph10%> + <%if Image10_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph10%> +
          + <%Paragraph10%> +
          + <%endif%> +<%endif%> +<%if Image11_medium_path or Paragraph11%> + <%if Image11_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph11%> +
          + <%Paragraph11%> +
          + <%endif%> +<%endif%> +<%if Image12_medium_path or Paragraph12%> + <%if Image12_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph12%> +
          + <%Paragraph12%> +
          + <%endif%> +<%endif%> +<%if Image13_medium_path or Paragraph13%> + <%if Image13_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph13%> +
          + <%Paragraph13%> +
          + <%endif%> +<%endif%> +<%if Image14_medium_path or Paragraph14%> + <%if Image14_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph14%> +
          + <%Paragraph14%> +
          + <%endif%> +<%endif%> +<%if Image15_medium_path or Paragraph15%> + <%if Image15_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph15%> +
          + <%Paragraph15%> +
          + <%endif%> +<%endif%> +<%if Image16_medium_path or Paragraph16%> + <%if Image16_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph16%> +
          + <%Paragraph16%> +
          + <%endif%> + +<%endif%> +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>ADMIN: EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor' AND user.Status neq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   + + + + + +
          +

          + +

          +

          +   + +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles, $ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if test%> +
          + Photos related to this one + <%set RelatedPhotos ||= "1"%> + <%if RelatedPhotos%> + + <%related_photos($RelatedPhotos)%> + <%loop related_photos_loop%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%shorten_it($Description,160)%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%endloop%> + + <%else%> +

          There are no related photos

          + <%endif%> +
          + +<%endif%> + + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_form.html new file mode 100644 index 0000000..fd8804c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/dev/local/include_form.html @@ -0,0 +1,273 @@ + +
          + +
          + +
          +
          +
          + +
          + <%~if config.db_gen_category_list == 2%> + + <%~set selected_cats = Links::Tools::category_list_selected%> + <%~loop selected_cats%> + + <%~endloop%> + +
          + + <%~elsif category_loop_selected%> + <%~if category_loop.length > 1%> +
            <%loop category_loop%>
          • <%Full_Name%>
          • <%endloop%>
          + <%~else%> + <%loop category_loop%><%Full_Name%><%endloop%> + <%~endif%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + <% if modify and Link_Type%> + + <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%> + <% else %> + + <% endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          style="display:none"<% endif %>> + +
          + +
          +
          +
          style="display:none"<%endif%>> + <% include include_form_video.html %> +
          +
          style="display:none"<%endif%>> + <% include include_form_article_photo.html %> +
          + +
          + + +
          + +
          +
          + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/.tplinfo b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/.tplinfo new file mode 100644 index 0000000..2707517 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/.tplinfo @@ -0,0 +1,3 @@ +{ + inheritance => '../browser' +} diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add.html new file mode 100644 index 0000000..007e9de --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add.html @@ -0,0 +1,49 @@ + + + + <%site_title%>: Add a Link +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Add a Link

          + +

          + Please completely fill out the form, and we'll add your link as soon as possible. +

          + +
          +<%include include_form.html%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add_success.html new file mode 100644 index 0000000..62e8bae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/add_success.html @@ -0,0 +1,81 @@ + + + + <%site_title%>: Link Added +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Link Added

          + +

          + We have received the following link: +

          + +
          + +
          <%Title%>
          +
          +
          + +
          <%escape_html URL%>
          +
          +
          + +
          +<%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          +<%~else%> + <%Category%> +<%~endif%> +
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +

          +<%~if config.build_auto_validate%> + Your link has been added to <%if Category_loop.length > 1%>the following categories: <%loop Category_loop%><%loop_value%><%unless last%>, <%endunless%><%endloop%><%else%><%Category%><%endif%>. +<%~else%> + Thank you! We will send you an e-mail once your link has been validated. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_add.html new file mode 100644 index 0000000..5b5d969 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_add.html @@ -0,0 +1,72 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: Add Folder +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Add Folder

          + +
          + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> +
          +
          +
          + +
          + checked="checked"<%endif%>> + checked="checked"<%endif%>> +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_edit.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_edit.html new file mode 100644 index 0000000..58b137b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_edit.html @@ -0,0 +1,73 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: Edit Folder +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Edit Folder

          + +
          + + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> +
          +
          +
          + +
          + checked="checked"<%endif%>> + checked="checked"<%endif%>> +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_view.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_view.html new file mode 100644 index 0000000..68ff2f0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_folder_view.html @@ -0,0 +1,69 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: <%escape_html my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          <%escape_html my_folder_username%><%if my_folder_name%>: <%my_folder_name%><%else%>'s Bookmarks<%endif%>

          + +

          +<%~if my_folder_name%> + There <%if link_count != 1%>are<%else%>is<%endif%> <%link_count%> link<%if link_count != 1%>s<%endif%> in this folder. +<%~else%> + <%if my_folder_username eq $user.Username%>You have<%else%><%escape_html my_folder_username%> has<%endif%> <%folder_count%> folder<%if folder_count != 1%>s<%endif%> with <%link_count%> link<%if link_count != 1%>s<%endif%>. +<%~endif%> +

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%if Folders.length~%> +
            +<%~loop Folders%> +
          • + <%my_folder_name%> (<%num_links%>) + <%if my_folder_description%>

            <%my_folder_description%>

            <%endif%> +
          • +<%~endloop%> +
          +<%~endif%> + +<%if Bookmarks.length~%> +<%~loop Bookmarks%> +

          <%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>

          +<%include bookmark_link.html%> +<%~endloop%> +<%~endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link.html new file mode 100644 index 0000000..83f6d19 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link.html @@ -0,0 +1,11 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_add.html new file mode 100644 index 0000000..fc6283e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_add.html @@ -0,0 +1,73 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: Add Bookmark +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Add Bookmark

          + +<%if URL~%> +

          + You are adding the following link to your bookmarks: +

          +<%~Links::Utils::load_link_info%> +<%include link.html%> +<%~endif%> + +
          + + +
          + +
          + +
          +
          +
          + +
          + <%~if Folders.length == 1%> + <%Folders.0.my_folder_name%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_edit.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_edit.html new file mode 100644 index 0000000..6a62858 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_link_edit.html @@ -0,0 +1,73 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: Edit Bookmark +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Edit Bookmark

          + +<%if URL~%> +

          + You are editing the bookmark of the following link: +

          +<%~Links::Utils::load_link_info%> +<%include link.html%> +<%~endif%> + +
          + + +
          + +
          + +
          +
          +
          + +
          + <%~if Folders.length == 1%> + <%Folders.0.my_folder_name%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_list.html new file mode 100644 index 0000000..f30510e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_list.html @@ -0,0 +1,86 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: <%if my_folder_name%>Bookmarks: <%my_folder_name%><%else%>My Bookmarks<%endif%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          <%if my_folder_name%><%my_folder_name%><%else%>My Bookmarks<%endif%>

          + +

          +<%~if my_folder_name%> + You have <%link_count%> link<%if link_count != 1%>s<%endif%> in this folder. +<%~else%> + You have <%folder_count%> folder<%if folder_count != 1%>s<%endif%> with <%link_count%> link<%if link_count != 1%>s<%endif%>. +<%~endif%> +

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%if Folders.length~%> +
            +<%~loop Folders%> +
          • + <%my_folder_name%> (<%num_links%>) + <%if my_folder_public%>public<%endif%> + <%if my_folder_default%>default<%endif%> + Edit + <%ifnot my_folder_default%>Delete<%endif%> + Manage + <%if my_folder_description%>

            <%my_folder_description%>

            <%endif%> +
          • +<%~endloop%> +
          +<%~endif%> + +<%if Bookmarks.length~%> +
          + + +<%~loop Bookmarks%> + +<%~set editable = 1%> +<%include bookmark_link.html%> +<%~endloop%> + +<%~if folder_select.length%> + + +<%~endif%> +
          +<%~endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_nav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_nav.html new file mode 100644 index 0000000..590929c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_nav.html @@ -0,0 +1,6 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_preferences.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_preferences.html new file mode 100644 index 0000000..6c555f2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_preferences.html @@ -0,0 +1,79 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: Preferences +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Preferences

          + +
          + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_users.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_users.html new file mode 100644 index 0000000..2840e97 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/bookmark_users.html @@ -0,0 +1,59 @@ + +<%~set secondarynav = "bookmark_nav.html"%> + + + <%site_title%>: Bookmarks: User List +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          User List

          + +

          +<%~if total_users%> + There <%if total_users != 1%>are<%else%>is<%endif%> <%total_users%> user<%if total_users != 1%>s<%endif%> with public folders. +<%~else%> + There are no users with public folders. +<%~endif%> +

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%if users~%> + +<%~endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/category.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/category.html new file mode 100644 index 0000000..801ddae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/category.html @@ -0,0 +1,87 @@ + +<%Links::Utils::load_editors~%> + + + <%site_title%>: <%category_name%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          + <%category_short%> +<%~if config.newsletter_enabled and not config.newsletter_global_subscribe%> + <%~Links::Newsletter::subscription_info($ID)%><%-- SubscriptionStatus: 0 = not subscribed, 1 = indirectly subscribed, 2 = directly subscribed --%> + <%if SubscriptionStatus == 2%>(Unsubscribe)<%elsif SubscriptionStatus == 1%><%else%>(Subscribe)<%endif%> +<%~endif%> +

          + +<%if category_loop.length~%> +

          Categories

          +<%~set split = Links::Utils::column_split($category_loop.length, $category_cols)%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> +
          +<%~endif%> + +<%if related_loop.length~%> +

          Related Categories

          + +<%endif%> + +<%if links_loop.length~%> +

          Links

          +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%loop links_loop~%> +<%include link.html%> +<%~endloop%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> +<%~endif%> + +<%if editors_loop.length~%> +

          Editors

          +
            +<%~loop editors_loop%> +
          • <%escape_html Username%>
          • +<%~endloop%> +
          +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/cool.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/cool.html new file mode 100644 index 0000000..5d5819e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/cool.html @@ -0,0 +1,47 @@ + + + + <%site_title%>: What's Cool +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Cool Links (top <%percent%>)

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%loop link_results_loop~%> +

          <%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>

          +<%include link.html%> +<%~endloop%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/detailed.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/detailed.html new file mode 100644 index 0000000..be20f7f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/detailed.html @@ -0,0 +1,88 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> + + + <%site_title%>: <%Title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          + +<%if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +<%if Description%>

          <%Description%>

          <%endif%> + +

          + Submitted by: <%escape_html LinkOwner%>
          + Hits: <%Hits%>
          + Added: <%Add_Date%>
          + <%if Add_Date ne $Mod_Date%>Last Modified: <%Mod_Date%>
          <%endif%> +

          + +

          + Review It + Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +<%if Review_Loop.length~%> +

          Reviews

          + +

          Add your own review

          + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read all <%Review_Total%> review<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/error.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/error.html new file mode 100644 index 0000000..baad816 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/error.html @@ -0,0 +1,47 @@ + +<%set error_message = $error~%> +<%set error = ''~%> + + + <%site_title%>: Error +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Error

          + +

          + Oops, we had the following problem: +

          +

          + <%error_message%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/globals.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/globals.txt new file mode 100644 index 0000000..122db94 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/globals.txt @@ -0,0 +1,17 @@ +{ + 'category_cols' => 2, + 'category_separator' => ' > ', + 'crumb_separator' => ' > ', + 'detailed_max_reviews' => 5, + 'home_category_cols' => 2, + 'paging_options' => 'sub { + return { + max_pages => 25, + boundary_pages => 1, + style => 1, + }; +}', + 'site_title' => 'Gossamer Links' +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/home.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/home.html new file mode 100644 index 0000000..11af8c7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/home.html @@ -0,0 +1,46 @@ + + + + <%site_title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%set split = Links::Utils::column_split($category_loop.length, $home_category_cols)~%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> +
          +

          There <%if grand_total != 1%>are<%else%>is<%endif%> <%grand_total%> link<%if grand_total != 1%>s<%endif%> for you to choose from!

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_accessibility.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_accessibility.html new file mode 100644 index 0000000..2c1b328 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_accessibility.html @@ -0,0 +1,2 @@ + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_common_head.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_common_head.html new file mode 100644 index 0000000..896b7f4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_common_head.html @@ -0,0 +1,29 @@ + +<%if Meta_Description%><%endif%> +<%if Meta_Keywords%><%endif%> +<%if theme%><%endif%> +<%~-- If your site is statically built, then the login status will always say 'Login/Register'. This javascript replaces it with 'Logout' if the user is logged in. --~%> +<%if not d and not user.Username~%> + + +<%~endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_content_bottom.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_content_bottom.html new file mode 100644 index 0000000..e69de29 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_content_top.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_content_top.html new file mode 100644 index 0000000..e69de29 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentfooter.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentfooter.html new file mode 100644 index 0000000..ed315d1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentfooter.html @@ -0,0 +1,4 @@ +<%-- +
          +
          +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentheader.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentheader.html new file mode 100644 index 0000000..43f489e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentheader.html @@ -0,0 +1,6 @@ +<%if error or message~%> +
          + <%if error%>
          <%error%>
          <%endif%> + <%if message%>
          <%message%>
          <%endif%> +
          +<%~endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentwrapper_bottom.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentwrapper_bottom.html new file mode 100644 index 0000000..e69de29 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentwrapper_top.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_contentwrapper_top.html new file mode 100644 index 0000000..e69de29 diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_footer.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_footer.html new file mode 100644 index 0000000..320490c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_footer.html @@ -0,0 +1,6 @@ +
          + +<%--if in.debug%><%DUMP%><%endif--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_form.html new file mode 100644 index 0000000..4f8d990 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_form.html @@ -0,0 +1,69 @@ +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + <%~if config.db_gen_category_list == 2%> + + <%~set selected_cats = Links::Tools::category_list_selected%> + <%~loop selected_cats%> + + <%~endloop%> + +
          + + <%~elsif category_loop_selected%> + <%~if category_loop.length > 1%> +
            <%loop category_loop%>
          • <%Full_Name%>
          • <%endloop%>
          + <%~else%> + <%loop category_loop%><%Full_Name%><%endloop%> + <%~endif%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_header.html new file mode 100644 index 0000000..727f05d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_header.html @@ -0,0 +1,27 @@ + + + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_leftsidebar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_leftsidebar.html new file mode 100644 index 0000000..7b090c1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_leftsidebar.html @@ -0,0 +1,3 @@ +<%-- Note that this left sidebar is not displayed by default. See the examples in static/luna/luna.css on how to display the sidebar. --%> + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_rightsidebar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_rightsidebar.html new file mode 100644 index 0000000..5b78245 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_rightsidebar.html @@ -0,0 +1,2 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_video_player.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_video_player.html new file mode 100644 index 0000000..1c6b927 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/include_video_player.html @@ -0,0 +1,25 @@ +<% if not image %> +<% Plugins::ConvertVideo::get_file_path($ID, "image_file_field") %> +<% set image = $image_file_field_path %> +<% endif %> +<% if not video %> +<% Plugins::ConvertVideo::get_file_path($ID, "flash_file_field") %> +<% set video = $flash_file_field_path %> +<% endif %> +<% Plugins::ConvertVideo::get_flash_dimension() %> +
          + +
          + +
          \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump.html new file mode 100644 index 0000000..8ac76b5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump.html @@ -0,0 +1,17 @@ + + + + <%site_title%>: <%Title%> + + + + + + <body> + <p> + Your browser does not support frames. Click the url to visit the page: <a href="<%destination%>"><%destination%></a> + </p> + </body> + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump_frame.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump_frame.html new file mode 100644 index 0000000..618aca0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/jump_frame.html @@ -0,0 +1,30 @@ + + + + <%site_title%>: <%if error%>Error<%else%><%Title%><%endif%> + +<%include include_common_head.html%> + + +
          + + + <%if error%> +

          + <%error%> +

          + <%else%> +

          + <%if detailed_url%><%endif%><%Title%><%if detailed_url%><%endif%> <%if Votes%><%set intRating = $Rating i/ 1%>" alt="<%intRating%> out of 10 stars" title="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>)<%endif%> +

          +
          + <%if Review_Count%>Read <%Review_Count%> Review<%if Review_Count != 1%>s<%endif%><%endif%> + Review Link + Rate Link + <%if config.bookmark_enabled%>Bookmark Link<%endif%> + Remove Frame +
          + <%endif%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/language.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/language.txt new file mode 100644 index 0000000..5579875 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/language.txt @@ -0,0 +1,183 @@ +{ + 'ADD_BADREFER' => 'Sorry, this site does not accept submissions from \'%s\'.', + 'ADD_BADSTATUS' => 'Your link could not be added because it is not accessible: %s.', + 'ADD_ILLEGALVAL' => '%s cannot contain the value \'%s\'', + 'ADD_INVALIDCAT' => 'Unable to find category with ID \'%s\'.', + 'ADD_NOCATEGORIES' => 'There are no categories to add a link to.', + 'ADD_NOCATEGORY' => 'You did not specify a category for this link.', + 'ADD_NOTNULL' => 'Column %s cannot be left blank.', + 'ADD_SELCAT' => 'Please first visit the category you wish to add or move your link to, then click on Add/Modify a Link.', + 'ADD_UNIQUE' => 'The column \'%s\' must be unique, and already has an entry \'%s\'.', + 'BOOKMARK_BAD_FOLDER' => 'Please enter a valid folder name.', + 'BOOKMARK_BAD_FOLDER_ID' => 'There is no folder with the id \'%s\'.', + 'BOOKMARK_COMMENTS_EDITED' => 'The comment has been updated.', + 'BOOKMARK_DISABLED' => 'Bookmarks have been disabled.', + 'BOOKMARK_FOLDER_DEFAULT' => 'You can\'t remove a default folder.', + 'BOOKMARK_FOLDER_DUPLICATE' => 'A folder with name \'%s\' already exists.', + 'BOOKMARK_FOLDER_INVALID' => 'The folder is invalid.', + 'BOOKMARK_FOLDER_LIMIT' => 'You have reached your folder limit and cannot create any more.', + 'BOOKMARK_FOLDER_MODIFIED' => 'The folder has been updated.', + 'BOOKMARK_FOLDER_NOTEMPTY' => 'You cannot delete a folder that is not empty.', + 'BOOKMARK_FOLDER_NOTEXISTS' => 'The folder does not exist.', + 'BOOKMARK_FOLDER_NOTPUBLIC' => 'The folder you tried to access is not open to the public.', + 'BOOKMARK_FOLDER_NO_MOVE' => 'You cannot move links to the folder with id \'%s\'.', + 'BOOKMARK_FOLDER_REMOVED' => 'The folder %s has been removed.', + 'BOOKMARK_LINK_ADDED' => 'The link has been bookmarked.', + 'BOOKMARK_LINK_EXISTS' => 'This link has already been bookmarked in the selected folder.', + 'BOOKMARK_LINK_LIMIT' => 'You may not add any more links as you have reached your limit.', + 'BOOKMARK_LINK_MOVED' => '%s link(s) have been moved to folder %s.', + 'BOOKMARK_LINK_NOTEXISTS' => 'The link with id \'%s\' doesn\'t exist in your bookmarks.', + 'BOOKMARK_LINK_REMOVED' => '%s link(s) have been removed from your bookmarks.', + 'BOOKMARK_NO_ACTION' => 'No action passed.', + 'BOOKMARK_PREFERENCES' => 'The bookmark preferences have been updated.', + 'BOOKMARK_PREF_INVALIDPERPAGE' => 'Links per page must be greater than 0.', + 'BOOKMARK_PUBLIC_USER' => 'You do not have permission to access %s\'s folders.', + 'BOOKMARK_USER_NOTEXISTS' => 'The user %s does not exist.', + 'BUILD_DETAILED_ARGS' => 'Invalid argument passed to build_detailed: %s', + 'BUILD_DETAILED_DISABLED' => 'Detailed pages are not enabled.', + 'BUILD_DETAILED_EXPIRED' => 'The link has not been paid for or has expired.', + 'BUILD_DETAILED_INVALIDID' => 'Invalid link id passed to build_detailed: %s', + 'BUILD_DETAILED_UNVAL' => 'The link has not yet been validated.', + 'DATE_UNIT_DAY' => 'Day', + 'DATE_UNIT_DAYS' => 'Days', + 'DATE_UNIT_MONTH' => 'Month', + 'DATE_UNIT_MONTHS' => 'Months', + 'DATE_UNIT_WEEK' => 'Week', + 'DATE_UNIT_WEEKS' => 'Weeks', + 'DATE_UNIT_YEAR' => 'Year', + 'DATE_UNIT_YEARS' => 'Years', + 'FILE_TABLE' => 'Table "%s" could not be loaded because "%s".', + 'FILE_TABLEFORMAT' => 'Table name for request improperly formed or possibly insecure.', + 'FILE_UNKNOWN' => 'Unknown File requested.', + 'GENERAL_BANNED' => 'Your host has been banned; please contact the site owner for details.', + 'GENERAL_DISABLED' => 'The site is down for maintenance, please try again shortly.', + 'GENERAL_ERROR' => 'An error has occurred.', + 'JUMP_INVALIDID' => 'Unable to find link with id: \'%s\'.', + 'LINKS_ADD' => 'Add a Link', + 'LINKS_ADD_SUCCESS' => 'Link Added', + 'LINKS_BOOKMARK' => 'Bookmarks', + 'LINKS_COOL' => 'Cool', + 'LINKS_EMAILPASS' => 'Forgotten Password', + 'LINKS_ERROR' => 'Error', + 'LINKS_LOGIN' => 'User Login', + 'LINKS_MODIFY' => 'Modify a Link', + 'LINKS_MODIFY_SUCCESS' => 'Link Modified', + 'LINKS_NEW' => 'New', + 'LINKS_NEWSLETTER' => 'Newsletter', + 'LINKS_PAGE' => 'Page %s', + 'LINKS_PAYMENT' => 'Payment', + 'LINKS_PAYMENT_SUCCESS' => 'Payment Confirmation', + 'LINKS_RATE' => 'Rate a Link', + 'LINKS_REVIEW' => 'Reviews', + 'LINKS_REVIEW_ADD' => 'Add a Review', + 'LINKS_REVIEW_EDIT' => 'Edit Review', + 'LINKS_SEARCH' => 'Search', + 'LINKS_SEARCH_RESULTS' => 'Search Results', + 'LINKS_SIGNUP' => 'User Sign Up', + 'LINKS_TOP' => 'Home', + 'LINKS_TOPRATED' => 'Top Rated Links', + 'LINKS_VALIDATE' => 'Validation', + 'MODIFY_BADSTATUS' => 'Your link could not be modified because it is not accessible: %s.', + 'MODIFY_BADURL' => 'We were unable to find the URL \'%s\' in the database. Please make sure you typed it in exactly as it appears in the directory.', + 'MODIFY_INVALIDLINKID' => 'Invalid link ID.', + 'MODIFY_NOCATEGORY' => 'You did not specify a category for this link.', + 'MODIFY_NOLINKS' => 'You do not have any links to modify.', + 'MODIFY_NOTOWNER' => 'You are not authorized to modify this link.', + 'MODIFY_NOURL' => 'You did not specify a link to modify.', + 'MODIFY_REJECTSUB' => 'Your change has been rejected.', + 'MODIFY_SELCAT' => 'Before you can modify your link, please go to the category your link is in, or the category you want to put it in and click modify.', + 'NEWSLETTERERR_ALREADYSUB' => 'You are already subscribed to the Newsletter.', + 'NEWSLETTERERR_NOACTION' => 'You did not specify what you want to do with the list.', + 'NEWSLETTERERR_NOCATSUB' => 'You didn\'t specify which category to subscribe to.', + 'NEWSLETTERERR_NOCATUNSUB' => 'You didn\'t specify which category to unsubscribe from.', + 'NEWSLETTERERR_NOTSUB' => 'You aren\'t subscribed to the Newsletter.', + 'NEWSLETTER_CATSUB' => 'You have subscribed to the selected categories.', + 'NEWSLETTER_CATUNSUB' => 'You have unsubscribed from the selected categories.', + 'NEWSLETTER_CATUPDATED' => 'Your subscriptions have been updated.', + 'NEWSLETTER_ROOTCAT' => 'Home', + 'NEWSLETTER_SUBSCRIBED' => 'You have successfully subscribed to the Newsletter.', + 'NEWSLETTER_UNSUBSCRIBED' => 'You have successfully unsubscribed from the Newsletter.', + 'PAGE_INVALIDCAT' => 'Category \'%s\' does not exist.', + 'PAGE_INVALIDDETAIL' => 'Unable to find detailed page: \'%s\'.', + 'PAYLOG_DEL_SUCCESS' => 'Payment log entry deleted.', + 'PAYLOG_INVALID_ID' => 'Invalid log ID.', + 'PAYMENTERR_DECLINED' => 'Your payment was declined.', + 'PAYMENTERR_DIRECT' => 'Your payment could not be processed. Please check the fields below and resubmit your payment.', + 'PAYMENTERR_INVALIDCATID' => 'Invalid category ID.', + 'PAYMENTERR_INVALIDLEVEL' => 'You have selected an invalid payment level.', + 'PAYMENTERR_INVALIDLINKID' => 'Invalid link ID.', + 'PAYMENTERR_INVALIDMETHOD' => 'You have selected an invalid payment method.', + 'PAYMENTERR_INVALIDTERM' => 'You have selected an invalid payment term.', + 'PAYMENTERR_NOLEVEL' => 'You must select a payment level.', + 'PAYMENTERR_NOMETHOD' => 'You must select a payment method.', + 'PAYMENTERR_NOTACCEPTED' => 'Payments are not accepted for the category the link is in.', + 'PAYMENTERR_NOTOWNER' => 'You can only make payments to your own links.', + 'PAYMENT_CURRENCY_FORMAT' => '$%s ', + 'PAYMENT_DIRECT_AuthorizeDotNet' => 'Authorize.Net', + 'PAYMENT_DIRECT_Moneris' => 'Moneris', + 'PAYMENT_REMOTE_2CheckOut' => '2CheckOut', + 'PAYMENT_REMOTE_APPROVED' => 'Approved remote payment received from %s', + 'PAYMENT_REMOTE_CANCELLED' => 'Cancelled payment notification received from %s', + 'PAYMENT_REMOTE_INVALIDIP' => 'A payment notification was received from %s with an unauthorized IP address.', + 'PAYMENT_REMOTE_INVALIDPW' => 'A payment notification was received from %s with an invalid password.', + 'PAYMENT_REMOTE_Manual' => 'Manual', + 'PAYMENT_REMOTE_PayPal' => 'PayPal', + 'PAYMENT_REMOTE_RECURRING_ACCEPTED' => 'Recurring payment notification received from %s', + 'PAYMENT_REMOTE_RECURRING_DECLINED' => 'Declined payment notification received from %s', + 'PAYMENT_REMOTE_REFUND' => 'Notification of payment refund received from %s', + 'PAYMENT_REMOTE_WorldPay' => 'WorldPay', + 'PAYMENT_TYPE_AMEX' => 'American Express', + 'PAYMENT_TYPE_DELTA' => 'Delta', + 'PAYMENT_TYPE_DINERS' => 'Diners Club', + 'PAYMENT_TYPE_DISC' => 'Discover', + 'PAYMENT_TYPE_EURO' => 'Eurocard', + 'PAYMENT_TYPE_JCB' => 'JCB', + 'PAYMENT_TYPE_MANUAL' => 'Manual', + 'PAYMENT_TYPE_MC' => 'MasterCard', + 'PAYMENT_TYPE_NOVA' => 'Nova', + 'PAYMENT_TYPE_PAYPAL' => 'PayPal', + 'PAYMENT_TYPE_SOLO' => 'Solo', + 'PAYMENT_TYPE_SWITCH' => 'Switch', + 'PAYMENT_TYPE_VISA' => 'VISA', + 'PAYMENT_TYPE_VISA_DEBIT' => 'VISA Debit', + 'RANDOM_NOLINKS' => 'No available links.', + 'RATE_INVALIDID' => 'Unable to find link with ID: \'%s\'.', + 'RATE_INVALIDRATE' => 'Please enter a number from 1 to 10.', + 'RATE_VOTED' => 'You have already voted for this link.', + 'REVIEW_ADD_WAIT' => 'You have already submitted a review for this link. Please wait for it to be validated.', + 'REVIEW_GUEST_EMAIL_REQUIRED' => 'Please enter your e-mail address to add a review!', + 'REVIEW_GUEST_NAME_REQUIRED' => 'Please fill out your name to add a review!', + 'REVIEW_INVALIDID' => 'Invalid Link ID : %s.', + 'REVIEW_INVALID_ACTION' => 'Invalid action!', + 'REVIEW_INVALID_UPDATE' => 'Unable to update review database. User is invalid for this review or the review is not validated.', + 'REVIEW_MAX_REVIEWS' => 'You can only add %s review(s) to a link.', + 'REVIEW_MODIFY_DENIED' => 'You do not have permission to modify your review.', + 'REVIEW_MODIFY_TIMEOUT' => 'The edit time for the review has expired.', + 'REVIEW_NORESULTS' => 'No reviews are available.', + 'REVIEW_NOT_EXISTS' => 'Review doesn\'t exist!', + 'REVIEW_RATING' => 'Please select a rating from 1 to 5 only.', + 'REVIEW_VOTED' => 'You have already voted for this review.', + 'SEARCH_NOLINKS' => 'No Matching Links.', + 'SUBSCRIBE_ALREADYSUB' => 'You are already subscribed to this mailing list.', + 'SUBSCRIBE_ERROR' => 'No action and/or e-mail specified.', + 'SUBSCRIBE_INVALIDLIST' => 'Unable to find mailing list: \'%s\'.', + 'SUBSCRIBE_NOTSUB' => 'You are not subscribed to this mailing list.', + 'SUBSCRIBE_SUCCESS' => 'You have successfully subscribed to the mailing list.', + 'SUBSCRIBE_UNSUBSUCCESS' => 'You have successfully unsubscribed from the mailing list.', + 'USER_AUTHERROR' => 'Authentication error: %s', + 'USER_BADLOGIN' => 'Invalid username/password.', + 'USER_EMAILTAKEN' => 'The e-mail address you entered is already taken.', + 'USER_INVALIDEMAIL' => 'Invalid e-mail address: \'%s\'', + 'USER_INVALIDNAME' => 'Invalid name: \'%s\'', + 'USER_INVALIDSIGNUP' => 'Please fill out all fields completely.', + 'USER_INVALIDUSERNAME' => 'Invalid format for username: %s', + 'USER_INVALIDVAL' => 'Invalid validation code.', + 'USER_LOGOUT' => 'You have been successfully logged out.', + 'USER_NAMETAKEN' => 'The username you requested is already taken.', + 'USER_NOEMAIL' => 'No user with that e-mail address.', + 'USER_NOTVAL' => 'This account has not yet been validated.', + 'USER_PASSSENT' => 'Your password has been successfully e-mailed to you.', + 'USER_VALSENT' => 'Your validation code has been sent!' +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link.html new file mode 100644 index 0000000..c15f5e1 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link.html @@ -0,0 +1,39 @@ +
          +

          + <%if detailed_url and isValidated eq 'Yes'%><%elsif URL ne 'http://' and isValidated eq 'Yes'%><%endif%><%if highlight%><%Links::Tools::highlight($Title, $query)%><%else%><%Title%><%endif%><%if isValidated eq 'Yes'%><%if detailed_url or URL ne 'http://'%><%endif%><%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> + <%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> + <%~endif%> +

          + <%if URL ne 'http://'%>

          <%if isValidated eq 'Yes'%><%endif%><%if highlight%><%set equery = escape_html $query%><%set eURL = escape_html $URL%><%Links::Tools::highlight($eURL, $equery)%><%else%><%escape_html URL%><%endif%><%if isValidated eq 'Yes'%><%endif%>

          <%endif%> + +

          + <%~if Votes%> + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" title="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) + <%~endif%> + <%~if paymentsEnabled and ExpiryDateFormatted and wasPaid%> + <%if isNotify or isExpired%><%endif%><%if isExpired%>Expired on:<%else%>Expiry date:<%endif%> <%ExpiryDateFormatted%><%if isNotify or isExpired%><%endif%> + <%~endif%> +

          + + <%if Description%>
          <%if highlight%><%Links::Tools::highlight($Description, $query)%><%else%><%Description%><%endif%>
          <%endif%> + +

          + <%~if isValidated eq Yes%> + <%if Review_Count%>Read <%Review_Count%> Review<%if Review_Count != 1%>s<%endif%><%endif%> + Review It + Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if not isExpired and not isUnpaid%> + <%if isLinkOwner or not config.user_required%>Edit this link<%endif%> + <%endif%> + <%~endif%> + <%if paymentsEnabled%><%if not wasPaid%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_added.eml new file mode 100644 index 0000000..239bbff --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_added.eml @@ -0,0 +1,34 @@ +To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your link has been approved + +Hello<%if Contact_Name%> <%Contact_Name%><%elsif Name%> <%Name%><%endif%>, + +Thank you for visiting our site. We've added the following link into +our directory: + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact E-mail: <%Contact_Email%> + +You can see your new listing at: + + <%config.build_root_url%>/<%home_index%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : link_added.eml + Description : This is the e-mail a user receives when their link is + validated. + Tags : All the properties of the link that was just validated + are available plus: + Category => The category the link was added to. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expired.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expired.eml new file mode 100644 index 0000000..af72019 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expired.eml @@ -0,0 +1,26 @@ +To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Expiry Notification + +Hello<%if Name%> <%Name%><%endif%>, + +The following link<%if expiry_links.length != 1%>s<%endif%> <%if expiry_links.length != 1%>have<%else%>has<%endif%> expired: + +<%loop expiry_links~%> + <%Title%> + Expiry Date: <%ExpiryDate%> + Renewal Payment: <%renewal_url%> +<%endloop%> +Please make a payment as soon as possible or contact us for more information. + +Sincerely, + +<%site_title%> + +<%~-- + File : link_expired.eml + Description : This is the e-mail a user receives when their link has + expired. + Tags : The Title, ID, and ExpiryDate of the links that have + expired are in the loop expired_links. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expiry_notify.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expiry_notify.eml new file mode 100644 index 0000000..c48c399 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_expiry_notify.eml @@ -0,0 +1,26 @@ +To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Expiry Notification + +Hello<%if Name%> <%Name%><%endif%>, + +The following link<%if expiry_links.length != 1%>s<%endif%> <%if expiry_links.length != 1%>are<%else%>is<%endif%> about to reach the expiry date: + +<%loop expiry_links~%> + <%Title%> + Expiry Date: <%ExpiryDate%> + Renewal Payment: <%renewal_url%> +<%endloop%> +Please make a payment as soon as possible or contact us for more information. + +Sincerely, + +<%site_title%> + +<%~-- + File : link_expiry_notify.eml + Description : This is the e-mail a user receives when their link is about + to expire. + Tags : The Title, ID, and ExpiryDate of the links that have + expired are in the loop expired_links. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_modified.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_modified.eml new file mode 100644 index 0000000..885702f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_modified.eml @@ -0,0 +1,33 @@ +To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your link has been successfully updated + +Hello<%if Contact_Name%> <%Contact_Name%><%elsif Name%> <%Name%><%endif%>, + +Thank you for visiting our site. We've modified your link as +you requested. Here's our new listing: + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact E-mail: <%Contact_Email%> + +You can see your updated listing at: + + <%config.build_root_url%>/<%home_index%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : link_modified.eml + Description : This is the e-mail a user receives when the changes the + user submitted via modify.cgi are approved by the admin. + Tags : All the properties of the link that was modified are + available. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_rejected.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_rejected.eml new file mode 100644 index 0000000..d987272 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/link_rejected.eml @@ -0,0 +1,28 @@ +To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your <%if modify%>change<%else%>link<%endif%> has been rejected + +Hello<%if Contact_Name%> <%Contact_Name%><%elsif Name%> <%Name%><%endif%>, + +Your link: + + <%URL%> + +that was submitted on <%Add_Date%> has been rejected +for one of the following reasons: + + 1. Unsuitable content. + 2. Duplicate URL. + +If you have any questions, please don't hesitate to ask. + +<%site_title%> + +<%~-- + File : link_rejected.eml + Description : This is the e-mail a user receives when their link is + rejected. It can be customized by the admin prior to + sending. + Tags : All the properties of the link that was rejected are + available. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/aboutus.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/aboutus.html new file mode 100644 index 0000000..88e74ec --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/aboutus.html @@ -0,0 +1,203 @@ + + + + <%site_title%>: About Us +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          About Us

          + +
          +
          Dan Empfield Slowtwitch Publisher: Born in California in 1957, Empfield is a graduate of South Tahoe High School and the University of Nevada (Reno), earning a Bachelor of Science in biology. +

          +Empfield competed in his first triathlon in 1978, and in the first Ironman held on Hawaii's Big Island, in 1981. +

          +He designed the original triathlon wetsuit, and founded wetsuit manufacturer Quintana Roo in 1987. +

          +In 1989 Empfield debuted another design, the first bike "built from the aerobars back." The first Quintana Roo Superform had 650c wheels front and back, and an 80-degree seat angle. Today�s modern triathlon and time trial bikes are progeny of the Superform. +

          +He sold Quintana Roo to Saucony, Inc., in 1995, and stayed on to run Saucony's bike division - which included Quintana Roo and Merlin - for four years. He left in 1999 and founded Slowtwitch.com. +

          +In 2003 Empfield developed the F.I.S.T. Tri Bike Fit System for triathletes, featuring "stack" and "reach," a set of bike fit metrics now popular among tri and road bike manufacturers and fitters. He's given fit clinics and workshops all over the United States and Europe. Today many modern fit systems employ the protocol, mechanics and metrics that are the backbone of the F.I.S.T. fit system. +

          +Empfield was inducted into the Triathlete Magazine Hall of Fame in 2004, and received the World Open Water Swimming Association's (WOWSA) lifetime achievement award in 2010. +

          +Empfield is a former USA Triathlon board member and, along with Lew Kidder, helped craft a set of USAT bylaws that reformed voting procedures, and redrew USAT voting regions. Most of those bylaws and districts remain in force today. +

          +Empfield hosted the U.S. Professional National Triathlon Championship in 1998, held in accordance with Olympic draft-legal rules. This race was part of the first national series devoted to Olympic-rules triathlon � a series Empfield produced and funded. +

          +Empfield continues to write for, and publish, Slowtwitch.com. He still swims, bikes, runs and races several times a year. He lives with wife Tanya, dogs, and horses on 8 acres in the San Gabriel Mountains of Southern California. +
          +
          +
          Herbert Krabel Slowtwitch Editor in Chief: Born and raised in Southern Germany, Krabel +graduated from Temple University in Philadelphia with a Bachelor of Arts +degree in Communication in 1991. +

          +While working full time at WYBE-TV 35 in Philadelphia as an editor, Krabel +raced Mountain Bikes in the Pro category from 1991 through 1996. In 1997 he +accepted a position as the Director of Marketing for Litespeed Titanium, the +company he had raced for professionally. After the acquisition of the +brands Quintana Roo and Merlin in 1999, the company became the American +Bicycle Group and Krabel took over world wide marketing for all the brands. +

          +In the spring of 2007 Krabel left the American Bicycle Group to start his +non traditional marketing firm called Guerrilla Communication. That summer +he also accepted the Editor in Chief position for Slowtwitch.com. He +currently holds both these positions. +

          +Krabel's athletic experiences include various Ironman finishes, the 24 Hours +of Canaan in West Virginia, Wilderness 101 and Punxsutawney 50 in +Pennsylvania and the Iditabike in Alaska. He lives with his wife Amy +Hildreth and Silvie the feisty cat in Winston-Salem, NC. +
          +
          +
          Jordan Rapp Slowtwitch Chief Technology Officer: After spending four years studying mechanical and aerospace engineering at Princeton University, Jordan Rapp only really came to enjoy it as a result of triathlon. A novice in all three sports, the idea of using equipment to go faster seemed like a great idea to a college rower used to racing for six minutes. 2012 was his 10th season of racing, and 7th as a pro, though he's enjoying a second crack at this whole triathlon thing and at life after being nearly killed in a hit-and-run in March of 2010 while riding his bicycle. +

          He earned his rainbow stripes by winning the ITU Long Distance World Championships in 2011. He's a five-time Ironman winner (US Championships in New York '12, Texas '12, Canada '09 & '11, and Arizona '09). And his first trip to the big dance in Kona in 2012 saw him finishing lucky number 13. +

          As CTO, Jordan is in charge of wrangling the multi-headed hydra of a website that is Slowtwitch.com. Despite being a somewhat Sisyphean ordeal, he nevertheless does his best to make sure Slowtwitch walks and talks the way it is supposed to. If you like Slowtwitch, feel free to let him know. If you don't, please tell Dan instead. Armed with his trusty Macbook Air, he tries to stay one step ahead of his ever growing “To Do” list. +

          More than a bit of a technophile, Jordan does the occasional product review for the site. Nothing makes him happier than cardboard boxes, with the possible exception of swim goggles, so this is the opiate that offsets the occasionally overwhelming job of coding the site. +

          Jordan also co-instructed the F.I.S.T. bike fit workshops with Dan for several years, where they helped people find enlightenment aboard a bicycle, before taking a leave of absence after the birth of his son. In addition to F.I.S.T.ing people, you can regularly find him around Xantusia where his favorite activity is climbing the mountain to Wrightwood, which is just about the only time Dan lets him away from his laptop. +

          Jordan is married to Canadian Olympian Jill Savege (Athens '04), winner of three ITU World Cups, and the holder of the best Kona debut in the house with a 10th place in 2001. They have one child - Quentin Thomas - born in 2011. +
          +
          +
          Timothy Carlson Slowtwitch Senior Correspondent and Photographer: Born in Daytona Beach, +Florida, Carlson is a graduate of Seabreeze Senior High where he set a +school record for most touchdown passes caught (and dropped) and ran a leg +on the state champion 880 relay in which he did not drop the baton. He also +cleared 8 feet 6 inches in the pole vault, landing six feet past the pit, +tumbled into a beautiful girl and subsequently asked her out. At Harvard +College, he punted for the freshman football squad until he sailed a kick +into a stuff wind which came backward, forcing him to down the ball before +it settled in the Crimson's end zone. In his sophomore year, he took +pictures for the Harvard Crimson daily newspaper and was on assignment +inside University Hall during a student occupation when he was arrested with +the demonstrators by Cambridge police. After successfully smuggling his +pictures out of jail, several of his photos appeared in Life Magazine +coverage of the event. +

          +In an eclectic post graduate period, he taught expository writing and worked +as a freelance writer and photographer during which he covered a wide range +of events including the Super Bowl, the Democratic and Republican +conventions, a coal miner's strike in West Virginia, the Daytona 500, NBA +finals and Palestinian refugees in Lebanon. In his most exciting assignment, +he served as a co-driver for the Polish Racing Drivers of America Ford +Econoline van in the original Cannonball Sea-to-Shining-Sea Memorial Trophy +Dash race from New York to Redondo Beach, California. With a makeshift +120-gallon fuel tank, no one smoked and the first gas stop was in Missouri. +

          +Finally gaining regular employment, he worked as a staff writer at the Los +Angeles Herald Examiner for 10 years, during which he wrote for the Style, +Sports, News, Magazine and editorial sections. During one feature +assignment, he rode as passenger at Riverside raceway in an off road truck +which flipped end over end. In another assignment to cover a murder in south +central LA, he was abducted and held overnight by a crack addict. At the +Herald's demise, he went to work for the LA Bureau of TV Guide magazine. +During that four year stint, he wrapped up a 10-year career racing off road +motorcycles (which included one spectacular crash which required he be +airlifted from Erendira to Scripps Hospital in San Diego)co-riding to a 5th +place finish in the Open Motorcycle division in the 1992 Baja 1000. +

          +Also during this period, Carlson took up running and triathlon. On a +freelance assignment for the LA Times covering the 1993 Hawaiian Ironman, +Dan Empfield lent the newbie a bike to ride on the Queen K and thus he was +forever hooked on the magnificent sport. +

          +From 1994 to 1999, Carlson wrote and took pictures for various multisport +magazines including Triathlete, Competitor, Multisport and Winning. From +1999 to July 2008, he moved to Boulder and served as editor and then senior +correspondent for Inside Triathlon. Since then, he happily signed on with +the Slowtwitch crew. +
          +
          +
          Jonathan Toker Slowtwitch Science Editor: Jonathan is an elite-level runner and triathlete +who hails from Canada and lives in Southern California. He received a Ph.D. +in organic chemistry from The Scripps Research Institute in 2001, and raced +in the professional ranks as a triathlete and runner for 5 years. A 9-time +Ironman finisher, with a personal best of 9:13, Jonathan recently completed +the arduous 6-day TransRockies running stage race and continues to seek new +athletic challenges. Dr. Toker worked as a scientist in the biotech +industry for 5 years prior to launching his unique SaltStick Electrolyte Capsule and Dispenser lineup. +
          +
          +
          Tanya Williams Slowtwitch Business Manager: Tanya comes from a background as a technical writer but her chief tasks, +beyond managing the office, are Social Secretary and Whip Cracker. +

          +Also among Tanya's duties are those that attend being Mrs. Slowman, so, the +two horses, seven dogs, and one husband are fed, housed, made presentable to +guests and visitors, and kept from barking and braying and otherwise +annoying the neighbors. +
          +
          +
          Mark Montgomery Xantusia Camp Host and Chief Storytelling Officer: Montomery's five-acre gentleman's ranch, adjacent to Empfield's ranchette +(the collection of properties is called "Xantusia"), is the place where +visiting pro triathletes, workshop attendees, manufacturers and others +headquarter themselves while on the property. "Monty's" job is to house, +feed, and ride and run with with guests of Xantusia, and to continue his +quest for the perfect margarita. +

          +Monty began his multisport career in the early 70's as a lifeguard working +the beaches of Los Angeles County. His forte was the "Lifeguard Ironman" +which included swimming, running, paddling, rowing, and kayaking. +In 1978 he began training for his first triathlon and won his first 3 races. +Since then Mark has over 60 multisport wins in over 400 races during a 15 +year pro career as a triathlete and bike racer. +

          +Montgomery has also worked "behind the camera" in triathlon, as promoter +and race director of over 50 races, including the Los Angeles Triathlon +Series (ongoing since 1982). He founded the Triaction Sports triathlon shop +in the late 80's, which at the time was the shop to the stars and +headquarters for the latest in new technology. He worked closely with Dan +Empfield in designing the tri-specific bike and wetsuit. +

          +Montgomery went back to work for the L.A. County Fire Department in 1994 as +a full time lifeguard retiring in 2003. He had a pacemaker installed in +2001, and after 18 months of recovery got himself back in shape and +qualified for the U.S. Worlds team in the 45+ age group. He competed on the +U.S. team in both New Zealand and Portugal (World Championship sites for +2003 and 2004). +
          +
          +
          Eric Wynn Photographer: +(the collection of properties is called "Xantusia"), is the place where +visiting pro triathletes, workshop attendees, manufacturers and others +headquarter themselves while on the property. "Monty's" job is to house, +feed, and ride and run with with guests of Xantusia, and to continue his +quest for the perfect margarita. +

          +
          +
          +(the collection of properties is called "Xantusia"), is the place where +visiting pro triathletes, workshop attendees, manufacturers and others +headquarter themselves while on the property. "Monty's" job is to house, +feed, and ride and run with with guests of Xantusia, and to continue his +quest for the perfect margarita. +

          +
          +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html new file mode 100644 index 0000000..0490e66 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html @@ -0,0 +1,61 @@ +<% set title = "Add a Link" %> + + + + <%site_title%>: <%title%> + + + +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          <% title %>

          +<%~ set megabytes = 1048576 ~%> +<%~ set image_cfg = Links::Plugins::get_plugin_user_cfg('SlideShow') ~%> +<%~ set image_size = image_cfg.max_upload_size / $megabytes ~%> +<%~ set image_size = round($image_size) ~%> +<%~ set video_max_size = Plugins::ConvertVideo::get_video_max_size() ~%> +<%~ set video_size = $video_max_size / $megabytes ~%> +<%~ set video_size = round($video_size) ~%> +

          + + Please completely fill out the form, and we'll add your article as soon as possible.
          + Note: image files must be smaller than <% if image_size %><% image_size %><%else%>1<%endif%>MB and video files must be smaller than <% if video_size %><% video_size %><%else%>1<%endif%>MB. +

          + +
          +<%include include_form.html%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html.bak2 new file mode 100644 index 0000000..d28b138 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add.html.bak2 @@ -0,0 +1,49 @@ + + + + <%site_title%>: Add an Article +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Add an Article

          + +

          + Please completely fill out the form, and we'll add your article as soon as possible. +

          + +
          +<%include include_form.html%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success.html new file mode 100644 index 0000000..ec47b37 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success.html @@ -0,0 +1,81 @@ + + + + <%site_title%>: Link Added +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Link Added

          + +

          + We have received the following link: +

          + +
          + +
          <%Title%>
          +
          +
          + +
          +<%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          +<%~else%> + <%Category%> +<%~endif%> +
          +
          +
          + +
          <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%>
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +

          +<%~if config.build_auto_validate%> + Your link has been added to <%if Category_loop.length > 1%>the following categories: <%loop Category_loop%><%loop_value%><%unless last%>, <%endunless%><%endloop%><%else%><%Category%><%endif%>. +<%~else%> + Thank you! We will send you an e-mail once your link has been validated. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success_publish.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success_publish.html new file mode 100644 index 0000000..e4c139e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/add_success_publish.html @@ -0,0 +1,193 @@ + + + + <%site_title%>: Publish Link to Social Media +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +<%if success%> +

          Link Published to Social Media

          +<%else%> +

          Publish Link to Social Media

          +<%endif%> + +<%set ID ||= 4031%> +<%Plugins::SocialMedia::format_link($ID)%> +<%-- + +--%> +<%if success%> + +The build is successful!

          + +<%if twitter_published%>It has been published to twitter.

          <%endif%> +<%if facebook_published%>It has been published to facebook. <%endif%> + +<%else%> + +

          + The following link has been created: +

          + +
          + +
          <%Title%>
          +
          +
          + +
          +<%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          +<%~else%> + <%Category%> +<%~endif%> +
          +
          +
          + +
          <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%>
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +

          +<%~if config.build_auto_validate%> + Your link has been added to <%if Category_loop.length > 1%>the following categories: <%loop Category_loop%><%loop_value%><%unless last%>, <%endunless%><%endloop%><%else%><%Category%><%endif%>. + You can preview the link at here. +<%~else%> + Thank you! We will send you an e-mail once your link has been validated. +<%~endif%> +

          + +<%-- +

          Build it?

          +

          +

          +
          + +
          +
          +

          +--%> + +

          Publish it?

          +

          +

          + +
          + +<%-- +
          + +
          + +
          +
          +
          + +
          + +
          +
          +--%> + +
          + +
          + Yes +
          +
          + +
          + +
          + +
          Use existing status line, or update as required. Link URL will be automatically appended to tweet. +
          +
          + +
          + +
          + +
          Please separate each hash tag with comma.
          For example: bike, runner, slowtwitch. +
          +
          + +
          + +
          + Yes +
          +
          +<%-- +
          + +
          +<%loop image_paths.images_loop%> + + +<%endloop%> +
          +
          +--%> + +<%--DUMP image_paths.images_loop--%> + +
          + +
          +
          +

          +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertise.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertise.html new file mode 100644 index 0000000..66ef8dd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertise.html @@ -0,0 +1,41 @@ + + + + <%site_title%>: Advertise +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          +Advertise +

          + + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertisers.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertisers.html new file mode 100644 index 0000000..82c7070 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/advertisers.html @@ -0,0 +1,8 @@ +
          + +<%ticker_loop%> +

          <%loop coupon_links_loop%> +<%coupon%>

          +<%endloop%>

          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/agreement.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/agreement.html new file mode 100644 index 0000000..d038a6b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/agreement.html @@ -0,0 +1,77 @@ + + + + <%site_title%>: User Agreement +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          +User Agreement +

          + +

          + Written by: Dan Empfield
          + Date: Tue Sep 18 2007
          +

          + +
          +
          + THIS AGREEMENT BINDS YOU +

          +
          Slowtwitch, Slowtwitch.com, and to its reader FORUM will cumulatively be called "Service". By using this Service, you agree to be bound by all of the terms of this Agreement. We reserve the right to change the terms of this Agreement or to modify features of this Service at any time. By registering for this Service and/or continuing to use this Service after the posting of Notices regarding such changes, you agree to be bound by such changes. +

          +
          WHAT YOU SEE AND READ ON THESE PAGES IS COPYRIGHT PROTECTED +

          +
          This Service (including, but not limited to, text, photographs, graphics and video content), except as noted in our Privacy Policy statement on FORUM authorship, is protected by copyright as a collective work or compilation under the copyright laws of the United States and other countries. All individual articles, content and other elements comprising this Service are also copyrighted works. You must abide by all additional copyright notices or restrictions contained in this Service. Reproduction of material from any Slowtwitch.com page without written permission by the Slowtwitch publisher (Dan Empfield) is strictly prohibited. +

          +
          IF YOU FEEL YOUR COPYRIGHT IS BEING ABUSED, PLEASE CONTACT US +

          +
          Just as Slowtwitch requires users to respect our copyrights, and those of our affiliates and partners, we respect the copyrights of others. If you believe in good faith that your copyrighted work has been reproduced on our site without authorization in a way that constitutes copyright infringement, please notify the Slowtwitch publisher via the contact information provided at the bottom of most Slowtwitch pages. +

          + +
          YOU ARE RESPONSIBLE FOR YOUR STATEMENTS +

          +
          You are responsible for all statements made or materials posted under your account, including liability for harm caused by such statements or materials. You may not transfer, sell, or otherwise assign your rights or obligations under this Agreement. By posting content on the Service, a user is giving Slowtwitch the right to display such content on the Service +

          +
          YOU HOLD US HARMLESS FOR YOUR BAD ACTS +

          +
          You agree to indemnify and hold harmless Slowtwitch, Slowtwitch.com, and its owners, directors, officers, managers, authors, contractors, employees, agents, and licensors, from and against all losses, expenses, damages and costs, including reasonable attorneys' fees, resulting from any violation of this Agreement, or the failure to fulfill any obligations relating to your account incurred by you or any other person using your account. We reserve the right to take over the exclusive defense of any claim for which we are entitled to indemnification under this Section. In such event, you shall provide us with such cooperation as is reasonably requested by us. +


          THIS SERVICE IS AVAILABLE "AS IS" +

          +
          We do not warrant that this Service will be uninterrupted or error-free. There may be delays, omissions, interruptions and inaccuracies in the news, information or other materials available through this Service. We are not responsible for the availability or content of other services that may be linked to this Service. Although we intend to take reasonable steps to prevent the introduction of viruses, worms, "Trojan horses" or other destructive materials to this Service, we do not guarantee or warrant that this Service or materials that may be downloaded from this Service do not contain such destructive features. We are not liable for any damages or harm attributable to such features. If you rely on this Service and any materials available through this Service, you do so solely at your own risk. +

          +
          This Agreement shall be governed by the laws of the United States and the State of California. BY CONTINUING TO READ AND USE SLOWTWITCH.COM, YOU AGREE TO ABIDE BY THE TERMS OF THIS AGREEMENT. +
          +
          + +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/category.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/category.html new file mode 100644 index 0000000..513fa84 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/category.html @@ -0,0 +1,93 @@ + +<%Links::Utils::load_editors~%> + + + <%site_title%>: <%category_name%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          + <%category_short%> +<%~if config.newsletter_enabled and not config.newsletter_global_subscribe%> + <%~Links::Newsletter::subscription_info($ID)%><%-- SubscriptionStatus: 0 = not subscribed, 1 = indirectly subscribed, 2 = directly subscribed --%> + <%if SubscriptionStatus == 2%>(Unsubscribe)<%elsif SubscriptionStatus == 1%><%else%>(Subscribe)<%endif%> +<%~endif%> +<%if test%> +    Click here to view the <%category_short%> Photo Gallery +<%endif%> +

          + +<%if category_loop.length~%> <%-- "~" removed from after loop.length--%> +

          Categories

          +<%~set split = Links::Utils::column_split($category_loop.length, $category_cols)%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> +
          +<%~endif%> <%-- "~" removed from before endif--%> + +<%if related_loop.length~%> +

          Related Categories

          + +<%endif%> + +<%if links_loop.length~%> <%-- "~" removed from after loop --%> +<%--h3>Articles +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%-- "~" removed from after loop and before endloop--%> +<%loop links_loop~%> +<%include link.html%> +<%~endloop%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> +<%~endif%> + +<%-- +<%if editors_loop.length~%> +

          Editors

          +
            +<%~loop editors_loop%> +
          • <%Username%>
          • +<%~endloop%> +
          +<%~endif%> +--%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html new file mode 100644 index 0000000..3215f85 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html @@ -0,0 +1,12 @@ +<%set detailed_url = get_detailed_url($ID)%> +<% if Link_Type eq 'article' %> +<% include include_detailed_article.html %> +<% elseif Link_Type eq 'photo' %> +<% if showLargePic eq 'Yes' %> +<% include include_detailed_photo_large.html %> +<% else %> +<% include include_detailed_photo.html %> +<% endif %> +<% else %> +<% include include_detailed_video.html %> +<% endif %> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html.bak2 new file mode 100644 index 0000000..5bb9fcc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/detailed.html.bak2 @@ -0,0 +1,411 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%site_title%>: <%Title%> + +<%--Facebook Meta Tags--%> + + + + + + +<%if Image1_thumbnail_path%> + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%include include_common_head.html%> + + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> + +<%--if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          + <%--Hits: <%Hits%>
          --%> + Date: <%Add_Date%>
          + <%--if Add_Date ne $Mod_Date%>Last Changed: <%Mod_Date%>
          <%endif--%> +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +<%--if Description%>

          <%Description%>

          <%endif--%> + +
          +<%if Image1_medium_path or Paragraph1%> + <%if Image1_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph1%> +
          + <%Paragraph1%> +
          + + <%endif%> +<%endif%> +<%if Image2_medium_path or Paragraph2%> + <%if Image2_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph2%> +
          + <%Paragraph2%> +
          + <%endif%> +<%endif%> +<%if Image3_medium_path or Paragraph3%> + <%if Image3_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph3%> +
          + <%Paragraph3%> +
          + <%endif%> +<%endif%> +<%if Image4_medium_path or Paragraph4%> + <%if Image4_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph4%> +
          + <%Paragraph4%> +
          + <%endif%> +<%endif%> +<%if Image5_medium_path or Paragraph5%> + <%if Image5_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph5%> +
          + <%Paragraph5%> +
          + <%endif%> +<%endif%> +<%if Image6_medium_path or Paragraph6%> + <%if Image6_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph6%> +
          + <%Paragraph6%> +
          + <%endif%> +<%endif%> +<%if Image7_medium_path or Paragraph7%> + <%if Image7_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph7%> +
          + <%Paragraph7%> +
          + <%endif%> +<%endif%> +<%if Image8_medium_path or Paragraph8%> + <%if Image8_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph8%> +
          + <%Paragraph8%> +
          + <%endif%> +<%endif%> +<%if Image9_medium_path or Paragraph9%> + <%if Image9_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph9%> +
          + <%Paragraph9%> +
          + <%endif%> +<%endif%> +<%if Image10_medium_path or Paragraph10%> + <%if Image10_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph10%> +
          + <%Paragraph10%> +
          + <%endif%> +<%endif%> +<%if Image11_medium_path or Paragraph11%> + <%if Image11_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph11%> +
          + <%Paragraph11%> +
          + <%endif%> +<%endif%> +<%if Image12_medium_path or Paragraph12%> + <%if Image12_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph12%> +
          + <%Paragraph12%> +
          + <%endif%> +<%endif%> +<%if Image13_medium_path or Paragraph13%> + <%if Image13_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph13%> +
          + <%Paragraph13%> +
          + <%endif%> +<%endif%> +<%if Image14_medium_path or Paragraph14%> + <%if Image14_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph14%> +
          + <%Paragraph14%> +
          + <%endif%> +<%endif%> +<%if Image15_medium_path or Paragraph15%> + <%if Image15_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph15%> +
          + <%Paragraph15%> +
          + <%endif%> +<%endif%> +<%if Image16_medium_path or Paragraph16%> + <%if Image16_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph16%> +
          + <%Paragraph16%> +
          + <%endif%> + +<%endif%> +
          + +

          + Comment on this article + <%if user.Status eq 'Administrator'%>ADMIN: EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor' AND user.Status neq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +

          +Share +   +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; + + +   +

          + +
          + +
          + +
          + <%adzone_300x250_1%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if test%> +
          + Photos related to this one + <%set RelatedPhotos ||= "1"%> + <%if RelatedPhotos%> + + <%related_photos($RelatedPhotos)%> + <%loop related_photos_loop%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%shorten_it($Description,160)%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%endloop%> + + <%else%> +

          There are no related photos

          + <%endif%> +
          + +<%endif%> + + +<%if Review_Loop.length~%> +

          Comments

          + +

          Add your own comment

          + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/dump.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/dump.html new file mode 100644 index 0000000..d0bb33b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/dump.html @@ -0,0 +1,40 @@ + + + + <%site_title%>: GLinks Variable Dump +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          GLinks Variable Dump

          + +<%--DUMP--%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/fist_downloads.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/fist_downloads.html new file mode 100644 index 0000000..31383f3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/fist_downloads.html @@ -0,0 +1,60 @@ + + + + FIST Downloads + + + F.I.S.T. RESOURCES +

          - Below are downloads. As F.I.S.T. graduates, you have limited use rights of the publications below. They are "Kinkos ready," that is, if you send any of these files (e.g., the manual, the printable worksheet) to FedexKinkos, and follow the instructions, they'll print it/them for you and you can pick them up, or have them shipped (or just burn them on a CD and hand carry them in).
          +
          + - The main resource, in additions to the downloads below, you'll find on our STACK/REACH database, which we always try to keep updated. From time to time we'll put out a call to those on our list who do what you do, to ask what isn't on that dbase that needs to be. Here you'll find our Handlebar to Head Tube Top calculator. Here is our Stem Calculator, a most helpful tool that very few fitters know about (or they'd be using it constantly).
          +
          + - Obviously, the generation of the stack & reach data is most helpful with the appropriate tools. The current best position simulators we know of are the GURU System 2 fit bike, and our special make-up of the Purely Custom fit bike that pretty much does everything you need for an affordable price. That second bike is available from us, including affordable financing. (Just call or email us.)
          +

          +

          DOWNLOADS

          +

          - F.I.S.T. Road Protocol (8.0): This 36-page pdf that accompanies the workshop.
          +
          + - F.I.S.T. Coordinates to Solutions (8.0): This 16-page pdf that accompanies the workshop.
          +
          + - Generic Fit Bike Manual (V1): This is the most up-to-date manual as of this writing (more recent than the two manuals referenced just above). There are some protocol differences between this and the other manuals. When the other manuals are updated they'll reflect the protocols in this manual.
          +
          + - Printable worksheet for road: This is brand new. It is a one-page worksheet on which you write in the sx/sy and hx/hy of each trial during the fit session. If you ask Kinkos to print these as "NCR carbonless duplicates," then 1 page goes to the customer, and one is retained in your file. Kinkos is familiar with this nomenclature.
          +
          + - Printable worksheet for tri: Same kinda thing, but for tri. +

          + - Logo-less worksheet for tri: The road worksheet without our logo, so that you can stick yours in if you'd like. +

          + - Printable worksheet for road: Logo-less tri worksheet.
          +
          + - Logo-less worksheet for road: Logo-less tri worksheet.
          +
          + NOTE: Only F.I.S.T.-Certified fitters are allowed to reprint the materials above, and only for use in that fitter's personal fit business, with his personal fit clients. Any other reprinting of the materials above is prohibited except through prior written consent of Dan Empfield.

          + - Trek Speed Concept Excel-based Armrest x/y Solver.
          +
          + - Felt IA Excel-based Armrest x/y Solver.
          +
          + - BMC TimeMachine x/y Solver.
          +
          + - Cervelo PDF-based P5 Armrest x/y Solver.
          +
          + - You may remember a cheat sheet I cobbled up for a retailer having problems with "no results" when clicking on the bike report on a popular bit of bike fit software. This Excel-based spreadsheet is designed to help you stay out of trouble. This was a quickie, generated in a hurry, and its accuracy should be gauged with that in mind. Best to keep HX in mind always during a fit while using a bike that generates this metric (GURU, Purely Custom, Shimano).
          +
          + - F.I.S.T. Logo: In jpg format below. Just drag and drop. Shoot me an email if you'd like a vectored version of this logo.

          +

          +
          +

          Reproduction of material from any Slowtwitch.com page
          + without written permission is strictly prohibited.
          + Copyright © 1999-2016 Slowtwitch.com
          + All rights reserved, Slowtwitch.com
          + 17116 Bob's Gap Rd, Valyermo, CA 93563-0056

          +
          Telephone 661•944•5239
          + slowman@slowtwitch.com
          +

          \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt new file mode 100644 index 0000000..3c4c92a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt @@ -0,0 +1,474 @@ +{ + 'ad_120x240' => ' + + + + + + + + +', + 'ad_120x600_noroadblocks' => ' + + + + + + + + + + + +', + 'ad_120x600_roadblocks' => ' + + + + + + + + + + + +', + 'ad_300x250_noroadblocks' => ' + + + + + + + + + + + +', + 'ad_300x250_roadblocks' => ' + + + + + + + + + + + +', + 'ad_728x90' => ' + + + + + + + + + + + +', + 'ad_728x90_roadblocks' => ' + + + + + + + + + + + +', + 'cat_match' => 'sub { + my $fullname = shift || return; + my $url = $DB->table(\'Category\')->as_url($fullname); + if (index($url, "Bike_Fit") != -1) { + return "true"; + } else { + return "false"; + } +}', + 'category_url' => 'sub { + my $fullname = shift || return; + my $url = $DB->table(\'Category\')->as_url($fullname); + return $url; +}', + 'comscore' => ' + + +', + 'convert_nl_br' => 'sub { + my $tags = GT::Template->tags; + foreach (keys %$tags) { + next if ($_ eq \'RelatedArticles\'); + $tags->{$_} =~ s/\r//g; + $tags->{$_} =~ s/\n/
          /g; + } + return $tags; +}', + 'dans_series' => '- F.I.S.T. Workshops +
          - Geometry Calculator +
          - Retailers +
          - Stack // Reach +
          - Training Log +
          - Triathlon Clubs', + 'ga_link_tracker' => ' +', + 'get_detailed_url' => 'sub { + my $id = shift; + return $CFG->{build_detail_url} . \'/\' . $DB->table(\'Links\')->detailed_url($id); +}', + 'get_footer_categories' => 'sub { +# usage ($depth, $sb, $so); + my $category = $DB->table(\'Category\'); + my $depth = shift || 0; + my $sb = shift || "Name"; + my $so = shift ||"ASC"; + my $pos = shift || 1; + + $category->select_options("ORDER BY $sb $so"); + my $sth = $category->select( { CatDepth => $depth, Cat_Pos => $pos }); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link->{URL} = "$CFG->{build_root_url}/" . $category->as_url($link->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : \'\'); + + push @loop, $link; + } + return { \'category_links_loop\' => \@loop }; +}', + 'get_header_categories' => 'sub { +# usage ($depth, $sb, $so); + my $category = $DB->table(\'Category\'); + my $depth = shift || 0; + my $sb = shift || "Name"; + my $so = shift ||"ASC"; + my $pos = shift || 0; + + $category->select_options("ORDER BY $sb $so"); + my $sth = $category->select( { CatDepth => $depth, Cat_Pos => $pos }); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link->{URL} = "$CFG->{build_root_url}/" . $category->as_url($link->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : \'\'); + + push @loop, $link; + } + return { \'category_links_loop\' => \@loop }; +}', + 'get_links' => 'sub { +# usage ($type, $sb, $so); + my $db = $DB->table(\'Links\'); + my $type = shift || "editorial"; + my $sb = shift || "Add_Date"; + my $so = shift ||"DESC"; + my $mh = shift || 10; + + $db->select_options("ORDER BY $sb $so", "LIMIT $mh"); + my $sth = $db->select({ Type => $type }, VIEWABLE); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { $type . \'_links_loop\' => \@loop }; +}', + 'get_links_categories' => 'sub { + my $links = shift; + my @ids = map { $_->{ID} } @$links; + my $catlink = $DB->table(\'CatLinks\',\'Category\'); + my %names = $catlink->select(\'LinkID\', \'Full_Name\', { LinkID => \@ids })->fetchall_list; + + return \%names; +}', + 'glam_widget' => ' +', + 'google_analytics' => ' +', + 'old_related_articles' => 'sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + my $db = $DB->table(\'Links\'); + require Links::SiteHTML; + foreach my $id (@ids) { + my $link = $db->get($id); + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { related_articles_loop => \@loop }; +}', + 'poll' => '', + 'quantcast' => ' + + + +', + 'related_articles' => 'sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + my $db = $DB->table(\'Links\'); + + my $linkid = shift; + my $cond = GT::SQL::Condition->new(); + $cond->add(\'RelatedArticles\',\'like\', \'%\' . $linkid . \'%\'); + my $sth = $db->select($cond); + my $seen = {}; + while (my $link = $sth->fetchrow_hashref()) { + $link = Links::SiteHTML::tags(\'link\',$link); + my @rids = split("\n", $link->{RelatedArticles}); + my $found = 0; + for (@rids) { + my $tid = $_; + $tid =~ s/\s+//g; + $found = 1 if ($tid == $linkid); + } + push @loop, $link if ($found); + $seen->{$link->{ID}} = 1 if ($found); + } + + require Links::SiteHTML; + foreach my $id (@ids) { + next if ($seen->{$id}); + my $rlink = $db->get($id); + if ($rlink) { + $rlink = Links::SiteHTML::tags(\'link\',$rlink); + push @loop, { %$rlink }; + } + } + return { related_articles_loop => \@loop }; +} +', + 'related_photos' => 'sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + use lib \'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin\'; + Links::init(\'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin\'); + require Plugins::SlideShow; + my $DBH = new GT::SQL \'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin/defs\'; + my $db = $DBH->table(\'Links\'); + require Links::SiteHTML; + foreach my $id (@ids) { + my $link = $db->get($id); + my $fh = $db->file_info("Image1_thumbnail", $link->{ID}); + my $fdir = $fh->File_Directory(); + my $full_path = "$fh"; + my $rel_path = $full_path; + $rel_path =~ s,$fdir,,; + $rel_path =~ s,%,%25,g; + + $link->{Image1_thumbnail_path} = $rel_path; + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { related_photos_loop => \@loop }; +}', + 'replace_line_break' => 'sub { + my $text = shift; + $text =~ s// /g; + return $text; +}', + 'rewrite_detail_url' => 'sub { + my $tags = GT::Template->tags; + if ($tags->{detailed_url} and !$IN->param(\'d\')) { + $tags->{detailed_url} =~ s/(\d+)\.html$/j$1.html/; + } + return $tags; +}', + 'round' => 'sub { + my $num = shift; + return sprintf("%.1f", $num - 0.05); +} +', + 'shorten_it' => 'sub { + my $str = shift; + my $length = shift || 160; + if ($length > 0 and length $str > $length) { + $str = substr($str,0,$length); + $str =~ s/\s+\w+$//g; + $str .= " ..."; + } + return $str; +}', + 'sidenav' => '', + 'sidenav_fitter' => '', + 'site_title' => '<:: Welcome to Slowtwitch.com ::>', + 'site_title_short' => 'Slowtwitch.com', + 'slowdrive' => '
          + + +
          + + + +
          +
          ', + 'thumbnail' => 'sub { + my $link = shift; + my $image1_thumbnail_path = shift; + if ($image1_thumbnail_path) { + return $image1_thumbnail_path; + } elsif ($link->{Link_Type} ne \'video\') { + return; + } + + if ($link->{Thumbnail_URL} and $link->{Thumbnail_URL} ne \'http://\') { + return $link->{Thumbnail_URL}; + } else { + require Plugins::ConvertVideo; + + my $field = Plugins::ConvertVideo::get_file_path($link->{ID}, "thumbnail_file_field"); + if ($field->{thumbnail_file_field_path}) { + return $field->{thumbnail_file_field_path}; + } + } + + return; +}', + 'ticker_loop' => 'sub { + my @coupon_links_loop; + my $db = $DB->table(\'Ticker\'); + my $sth = $db->do(\'SELECT ticker_text, ticker_link FROM glinks_Ticker ORDER BY ticker_text ASC\'); + while (my $result = $sth->fetchrow_hashref) { + push @coupon_links_loop, { + coupon => $result->{ticker_text}, + url => $result->{ticker_link} + }; + } + + return { \'coupon_links_loop\' => \@coupon_links_loop }; +}' +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt.dev b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt.dev new file mode 100644 index 0000000..aa10f06 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/globals.txt.dev @@ -0,0 +1,354 @@ +{ + 'adzone_120x240_1' => ' + + + + +', + 'adzone_120x60_3' => ' + + + + +', + 'adzone_120x90_5' => ' + + + + +', + 'adzone_120x90_6' => ' + + + + +', + 'adzone_120x90_7' => ' + + + + +', + 'adzone_120x90_zone1' => ' + + + + +', + 'adzone_300x250_1' => ' + + + + +', + 'adzone_728x90_1' => ' + + + + +', + 'adzone_skyscraper_1' => ' + + + + +', + 'category_url' => 'sub { + my $fullname = shift || return; + my $url = $DB->table(\'Category\')->as_url($fullname); + return $url; +}', + 'convert_nl_br' => 'sub { + my $tags = GT::Template->tags; + foreach (keys %$tags) { + next if ($_ eq \'RelatedArticles\'); + $tags->{$_} =~ s/\r//g; + $tags->{$_} =~ s/\n/
          /g; + } + return $tags; +}', + 'dans_series' => '- F.I.S.T. Workshops +
          - Geometry Calculator +
          - Retailers +
          - Stack // Reach +
          - Training Log +
          - Triathlon Clubs', + 'get_detailed_url' => 'sub { + my $id = shift; + return $CFG->{build_detail_url} . \'/\' . $DB->table(\'Links\')->detailed_url($id); +} +', + 'get_footer_categories' => 'sub { +# usage ($depth, $sb, $so); + my $category = $DB->table(\'Category\'); + my $depth = shift || 0; + my $sb = shift || "Name"; + my $so = shift ||"ASC"; + my $pos = shift || 1; + + $category->select_options("ORDER BY $sb $so"); + my $sth = $category->select( { CatDepth => $depth, Cat_Pos => $pos }); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link->{URL} = "$CFG->{build_root_url}/" . $category->as_url($link->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : \'\'); + + push @loop, $link; + } + return { \'category_links_loop\' => \@loop }; +}', + 'get_header_categories' => 'sub { +# usage ($depth, $sb, $so); + my $category = $DB->table(\'Category\'); + my $depth = shift || 0; + my $sb = shift || "Name"; + my $so = shift ||"ASC"; + my $pos = shift || 0; + + $category->select_options("ORDER BY $sb $so"); + my $sth = $category->select( { CatDepth => $depth, Cat_Pos => $pos }); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link->{URL} = "$CFG->{build_root_url}/" . $category->as_url($link->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : \'\'); + + push @loop, $link; + } + return { \'category_links_loop\' => \@loop }; +}', + 'get_links' => 'sub { +# usage ($type, $sb, $so); + my $db = $DB->table(\'Links\'); + my $type = shift || "editorial"; + my $sb = shift || "Add_Date"; + my $so = shift ||"DESC"; + my $mh = shift || 10; + + $db->select_options("ORDER BY $sb $so", "LIMIT $mh"); + my $sth = $db->select({ Type => $type }, VIEWABLE); + my @loop; + while (my $link = $sth->fetchrow_hashref) { + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { $type . \'_links_loop\' => \@loop }; +}', + 'get_links_categories' => 'sub { + my $links = shift; + my @ids = map { $_->{ID} } @$links; + my $catlink = $DB->table(\'CatLinks\',\'Category\'); + my %names = $catlink->select(\'LinkID\', \'Full_Name\', { LinkID => \@ids })->fetchall_list; + + return \%names; +}', + 'glam_widget' => ' +', + 'poll' => '', + 'related_articles' => 'sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + my $db = $DB->table(\'Links\'); + require Links::SiteHTML; + foreach my $id (@ids) { + my $link = $db->get($id); + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { related_articles_loop => \@loop }; +}', + 'related_photos' => 'sub { + my $related = shift || return; + my @ids = split ("\n",$related); + my @loop; + use lib \'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin\'; + Links::init(\'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin\'); + require Plugins::SlideShow; + my $DBH = new GT::SQL \'/home/slowtwitch/slowtwitch.com/cgi-bin/photos/admin/defs\'; + my $db = $DBH->table(\'Links\'); + require Links::SiteHTML; + foreach my $id (@ids) { + my $link = $db->get($id); + my $fh = $db->file_info("Image1_thumbnail", $link->{ID}); + my $fdir = $fh->File_Directory(); + my $full_path = "$fh"; + my $rel_path = $full_path; + $rel_path =~ s,$fdir,,; + $rel_path =~ s,%,%25,g; + + $link->{Image1_thumbnail_path} = $rel_path; + $link = Links::SiteHTML::tags(\'link\',$link); + push @loop, $link; + } + return { related_photos_loop => \@loop }; +}', + 'replace_line_break' => 'sub { + my $text = shift; + $text =~ s// /g; + return $text; +}', + 'rewrite_detail_url' => 'sub { + my $tags = GT::Template->tags; + if ($tags->{detailed_url} and !$IN->param(\'d\')) { + $tags->{detailed_url} =~ s/(\d+)\.html$/j$1.html/; + } + return $tags; +}', + 'round' => 'sub { + my $num = shift; + return sprintf("%.1f", $num - 0.05); +} +', + 'shorten_it' => 'sub { + my $str = shift; + my $length = shift || 160; + if ($length > 0 and length $str > $length) { + $str = substr($str,0,$length); + $str =~ s/\s+\w+$//g; + $str .= " ..."; + } + return $str; +}', + 'sidenav' => '', + 'site_title' => '<:: Welcome to Slowtwitch.com ::>', + 'site_title_short' => 'Slowtwitch.com', + 'thumbnail' => 'sub { + my $link = shift; + my $image1_thumbnail_path = shift; + if ($image1_thumbnail_path) { + return $image1_thumbnail_path; + } elsif ($link->{Link_Type} ne \'video\') { + return; + } + + if ($link->{Thumbnail_URL} and $link->{Thumbnail_URL} ne \'http://\') { + return $link->{Thumbnail_URL}; + } else { + require Plugins::ConvertVideo; + + my $field = Plugins::ConvertVideo::get_file_path($link->{ID}, "thumbnail_file_field"); + if ($field->{thumbnail_file_field_path}) { + return $field->{thumbnail_file_field_path}; + } + } + + return; +} +', + 'ticker_loop' => 'sub { + my @coupon_links_loop; + my $db = $DB->table(\'Ticker\'); + my $sth = $db->do(\'SELECT ticker_text, ticker_link FROM glinks_Ticker ORDER BY ticker_text ASC\'); + while (my $result = $sth->fetchrow_hashref) { + push @coupon_links_loop, { + coupon => $result->{ticker_text}, + url => $result->{ticker_link} + }; + } + + return { \'coupon_links_loop\' => \@coupon_links_loop }; +}', + 'unescape_tags' => 'sub { + my $text = shift; + + my @tags = (\'b\', \'i\', \'u\'); + + foreach my $tag (@tags) { + $text =~ s/<$tag>/<$tag>/g; + $text =~ s/<\/$tag>/<\/$tag>/g; + } + + return $text; +} +' +}; + +# vim:syn=perl:ts=4:noet diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html new file mode 100644 index 0000000..f6701c5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html @@ -0,0 +1,120 @@ + + + + <%site_title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          + +<%include include_content_top.html%> + +<%--set split = Links::Utils::column_split($category_loop.length, $home_category_cols)~%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> + + +<%-- latest articles --%> +
          +
          +

          +<%get_links('news','Add_Date DESC, Timestmp','DESC',20)%> +<%set i=1%> +<%loop news_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          +<%if Link_Type eq "photo" and showLargePic eq "no" %> <%endif%><%if Link_Type eq "video" OR hasVideo eq "Yes" %> <%endif%><%Title%>
          +<%--a href="<%detailed_url%>" class="headline"><%Title%><%if Link_Type eq "photo" and showLargePic eq "no" %> <%endif%><%if Link_Type eq "video" %> <%endif%>
          + + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 5%> +
          + <%ad_300x250_noroadblocks%> +
          + <%endif%> + <%if i = 9%%> +
          + +
          +<%endif%> +<%set i=i+1%> +<%endloop%> +
          + + +
          +

          +<%get_links('editorial','Add_Date DESC, Timestmp','DESC',16)%> +<%set i=1%> +<%loop editorial_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb%>
          + +
          <%endif%> +
          + <%if Link_Type eq "photo" and showLargePic eq "no" %> <%endif%><%if Link_Type eq "video" OR hasVideo eq "Yes" %> <%endif%><%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 3%> +
          + <%ad_300x250_roadblocks%> +
          + <%endif%> + <%if i = 7%> +
          + <%ad_300x250_noroadblocks%> +
          + <%endif%> + <%if i = 11%> +
          + + +
          + <%endif%> + +<%set i=i+1%> +<%endloop%> +
          +
          +<%--h4>There <%if grand_total != 1%>are<%else%>is<%endif%> <%grand_total%> link<%if grand_total != 1%>s<%endif%> for you to choose from! + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html.bak2 new file mode 100644 index 0000000..b886f12 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home.html.bak2 @@ -0,0 +1,148 @@ + + + + <%site_title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          + +
          +
          + +<%include include_content_top.html%> + +<%--set split = Links::Utils::column_split($category_loop.length, $home_category_cols)~%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> + + +<%-- latest articles --%> +
          +
          +

          +<%get_links('news','Add_Date DESC, Timestmp','DESC',20)%> +<%set i=1%> +<%loop news_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 5%> +
          + <%adzone_300x250_1%> +
          + <%endif%> + <%if i = 9%%> +
          + +
          +<%endif%> +<%set i=i+1%> +<%endloop%> +
          + + +
          +

          +<%get_links('editorial','Add_Date','DESC',18)%> +<%set i=1%> +<%loop editorial_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 2%> +
          + <%adzone_300x250_1%> +
          + <%endif%> + <%if i = 6%> +
          + <%adzone_300x250_1%> +
          + <%endif%> + <%if i = 11%> +
          + + +
          + <%endif%> + +<%set i=i+1%> +<%endloop%> +
          +
          +<%--h4>There <%if grand_total != 1%>are<%else%>is<%endif%> <%grand_total%> link<%if grand_total != 1%>s<%endif%> for you to choose from! + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home_sidenav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home_sidenav.html new file mode 100644 index 0000000..bd9bcef --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/home_sidenav.html @@ -0,0 +1,102 @@ + + + + <%site_title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          + +
          +
          + +<%include include_content_top.html%> + +<%--set split = Links::Utils::column_split($category_loop.length, $home_category_cols)~%> +
          +<%loop category_loop%> + <%~set splitmod = $row_num % $split%> + <%~if row_num == 1 or splitmod == 1 or split == 1%>
          <%endif%> +<%~include subcategory.html%> + <%~if row_num == $category_loop.length or splitmod == 0%>
          <%endif%> +<%~endloop%> + + +<%-- latest articles --%> +
          +
          +

          +<%get_links('news','Add_Date','DESC',20)%> +<%set i=1%> +<%loop news_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 10%> +
          + <%adzone_300x250_zone22%> +
          + <%endif%> +<%set i=i+1%> +<%endloop%> +
          + + +
          +

          +<%get_links('editorial','Add_Date','DESC',20)%> +<%set i=1%> +<%loop editorial_links_loop%> +<%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%if i = 5%> +
          + <%adzone_300x250_1%> +
          + <%endif%> +<%set i=i+1%> +<%endloop%> +
          +
          +<%--h4>There <%if grand_total != 1%>are<%else%>is<%endif%> <%grand_total%> link<%if grand_total != 1%>s<%endif%> for you to choose from! + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar_sidenav.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_advertisers.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_advertisers.html new file mode 100644 index 0000000..bcc3023 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_advertisers.html @@ -0,0 +1,7 @@ +
          + +<%ticker_loop%> + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_common_head.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_common_head.html new file mode 100644 index 0000000..f24cf4a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_common_head.html @@ -0,0 +1,78 @@ + + +<%if Meta_Description%><%endif%> +<%if Meta_Keywords%><%endif%> + + +<%if theme%><%endif%> +<%~-- If your site is statically built, then the login status will always say 'Login/Register'. This javascript replaces it with 'Logout' if the user is logged in. --~%> +<%if not d and not user.Username~%> + +<%-- + +--%> +<%~endif%> + + + + +<%google_analytics%> +<%ga_link_tracker%> +<%comscore%> +<%quantcast%> + + + + + +<%--DoubleClick Ad Code--%> + + + + +<%--Facebook Hide Share Bar Code--%> + + + +<%--End Facebook Hide Share Bar Code--%> + + + + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_content_top.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_content_top.html new file mode 100644 index 0000000..dbf688b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_content_top.html @@ -0,0 +1,7 @@ +<%--Plugins::MostPopular::generate_popular_links%>

          Most popular articles over the course of the last week from <%FromDate%> to <%ToDate%>

          +

          <%loop MostPopularLinks%> +<%Title%> (# of views: <%count%>)
          +<%endloop%>

          + +

          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html new file mode 100644 index 0000000..4088e33 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html @@ -0,0 +1,414 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + + + +<%--meta property="fb:admins" content="100001571171264,721935200,100004276806266" /--%> +<%--Twitter Meta Tags--%> + + + + + +<%if Image1_thumbnail_path%> + + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> +<%include include_common_head.html%> + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> + +<%--if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          + <%--Hits: <%Hits%>
          --%> + Date: <%Add_Date%>
          + <%--if Add_Date ne $Mod_Date%>Last Changed: <%Mod_Date%>
          <%endif--%> + +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +<%--if Description%>

          <%Description%>

          <%endif--%> + +
          +<%if Image1_medium_path or Paragraph1%> + <%if Image1_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph1%> +
          + <%Paragraph1%> +
          + + <%endif%> +<%endif%> +<%if Image2_medium_path or Paragraph2%> + <%if Image2_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph2%> +
          + <%Paragraph2%> +
          + <%endif%> +<%endif%> +<%if Image3_medium_path or Paragraph3%> + <%if Image3_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph3%> +
          + <%Paragraph3%> +
          + <%endif%> +<%endif%> +<%if Image4_medium_path or Paragraph4%> + <%if Image4_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph4%> +
          + <%Paragraph4%> +
          + <%endif%> +<%endif%> +<%if Image5_medium_path or Paragraph5%> + <%if Image5_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph5%> +
          + <%Paragraph5%> +
          + <%endif%> +<%endif%> +<%if Image6_medium_path or Paragraph6%> + <%if Image6_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph6%> +
          + <%Paragraph6%> +
          + <%endif%> +<%endif%> +<%if Image7_medium_path or Paragraph7%> + <%if Image7_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph7%> +
          + <%Paragraph7%> +
          + <%endif%> +<%endif%> +<%if Image8_medium_path or Paragraph8%> + <%if Image8_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph8%> +
          + <%Paragraph8%> +
          + <%endif%> +<%endif%> +<%if Image9_medium_path or Paragraph9%> + <%if Image9_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph9%> +
          + <%Paragraph9%> +
          + <%endif%> +<%endif%> +<%if Image10_medium_path or Paragraph10%> + <%if Image10_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph10%> +
          + <%Paragraph10%> +
          + <%endif%> +<%endif%> +<%if Image11_medium_path or Paragraph11%> + <%if Image11_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph11%> +
          + <%Paragraph11%> +
          + <%endif%> +<%endif%> +<%if Image12_medium_path or Paragraph12%> + <%if Image12_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph12%> +
          + <%Paragraph12%> +
          + <%endif%> +<%endif%> +<%if Image13_medium_path or Paragraph13%> + <%if Image13_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph13%> +
          + <%Paragraph13%> +
          + <%endif%> +<%endif%> +<%if Image14_medium_path or Paragraph14%> + <%if Image14_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph14%> +
          + <%Paragraph14%> +
          + <%endif%> +<%endif%> +<%if Image15_medium_path or Paragraph15%> + <%if Image15_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph15%> +
          + <%Paragraph15%> +
          + <%endif%> +<%endif%> +<%if Image16_medium_path or Paragraph16%> + <%if Image16_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph16%> +
          + <%Paragraph16%> +
          + <%endif%> + +<%endif%> +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>ADMIN: EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor' AND user.Status neq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles, $ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if test%> +
          + Photos related to this one + <%set RelatedPhotos ||= "1"%> + <%if RelatedPhotos%> + + <%related_photos($RelatedPhotos)%> + <%loop related_photos_loop%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%shorten_it($Description,160)%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%endloop%> + + <%else%> +

          There are no related photos

          + <%endif%> +
          + +<%endif%> + + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html.bak2 new file mode 100644 index 0000000..c679dc4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_article.html.bak2 @@ -0,0 +1,438 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + + + +<%--Twitter Meta Tags--%> + + + + + +<%if Image1_thumbnail_path%> + + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> +<%include include_common_head.html%> + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> + +<%--if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          + <%--Hits: <%Hits%>
          --%> + Date: <%Add_Date%>
          + <%--if Add_Date ne $Mod_Date%>Last Changed: <%Mod_Date%>
          <%endif--%> + +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +<%--if Description%>

          <%Description%>

          <%endif--%> + +
          +<%if Image1_medium_path or Paragraph1%> + <%if Image1_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph1%> +
          + <%Paragraph1%> +
          + + <%endif%> +<%endif%> +<%if Image2_medium_path or Paragraph2%> + <%if Image2_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph2%> +
          + <%Paragraph2%> +
          + <%endif%> +<%endif%> +<%if Image3_medium_path or Paragraph3%> + <%if Image3_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph3%> +
          + <%Paragraph3%> +
          + <%endif%> +<%endif%> +<%if Image4_medium_path or Paragraph4%> + <%if Image4_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph4%> +
          + <%Paragraph4%> +
          + <%endif%> +<%endif%> +<%if Image5_medium_path or Paragraph5%> + <%if Image5_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph5%> +
          + <%Paragraph5%> +
          + <%endif%> +<%endif%> +<%if Image6_medium_path or Paragraph6%> + <%if Image6_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph6%> +
          + <%Paragraph6%> +
          + <%endif%> +<%endif%> +<%if Image7_medium_path or Paragraph7%> + <%if Image7_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph7%> +
          + <%Paragraph7%> +
          + <%endif%> +<%endif%> +<%if Image8_medium_path or Paragraph8%> + <%if Image8_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph8%> +
          + <%Paragraph8%> +
          + <%endif%> +<%endif%> +<%if Image9_medium_path or Paragraph9%> + <%if Image9_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph9%> +
          + <%Paragraph9%> +
          + <%endif%> +<%endif%> +<%if Image10_medium_path or Paragraph10%> + <%if Image10_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph10%> +
          + <%Paragraph10%> +
          + <%endif%> +<%endif%> +<%if Image11_medium_path or Paragraph11%> + <%if Image11_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph11%> +
          + <%Paragraph11%> +
          + <%endif%> +<%endif%> +<%if Image12_medium_path or Paragraph12%> + <%if Image12_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph12%> +
          + <%Paragraph12%> +
          + <%endif%> +<%endif%> +<%if Image13_medium_path or Paragraph13%> + <%if Image13_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph13%> +
          + <%Paragraph13%> +
          + <%endif%> +<%endif%> +<%if Image14_medium_path or Paragraph14%> + <%if Image14_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph14%> +
          + <%Paragraph14%> +
          + <%endif%> +<%endif%> +<%if Image15_medium_path or Paragraph15%> + <%if Image15_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph15%> +
          + <%Paragraph15%> +
          + <%endif%> +<%endif%> +<%if Image16_medium_path or Paragraph16%> + <%if Image16_medium_path%> +
          + +
          + <%endif%> + <%if Paragraph16%> +
          + <%Paragraph16%> +
          + <%endif%> + +<%endif%> +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>ADMIN: EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor' AND user.Status neq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   + + + + + +
          +

          + +

          +

          +   + +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles, $ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if test%> +
          + Photos related to this one + <%set RelatedPhotos ||= "1"%> + <%if RelatedPhotos%> + + <%related_photos($RelatedPhotos)%> + <%loop related_photos_loop%> +
          + <%if Image1_thumbnail_path%>
          + +
          <%endif%> +
          + <%Title%>
          + <%shorten_it($Description,160)%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          + <%endloop%> + + <%else%> +

          There are no related photos

          + <%endif%> +
          + +<%endif%> + + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo.html new file mode 100644 index 0000000..0d08e6e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo.html @@ -0,0 +1,244 @@ + + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + + + +<%--meta property="fb:admins" content="100001571171264,721935200,100004276806266" /--%> +<%--Twitter Meta Tags--%> + + + + + +<%if Image1_thumbnail_path%> + + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> + + +<%include include_common_head.html%> + + + + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          + +<%-- +<%if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif%> +--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          +<%-- Hits: <%Hits%>
          --%> + Added: <%Add_Date%>
          + <%if Add_Date ne $Mod_Date%>Last Modified: <%Mod_Date%>
          <%endif%> +
          +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +
          +
          +<%if Image1%><%endif%> +<%if Image2%><%endif%> +<%if Image3%><%endif%> +<%if Image4%><%endif%> +<%if Image5%><%endif%> +<%if Image6%><%endif%> +<%if Image7%><%endif%> +<%if Image8%><%endif%> +<%if Image9%><%endif%> +<%if Image10%><%endif%> +<%if Image11%><%endif%> +<%if Image12%><%endif%> +<%if Image13%><%endif%> +<%if Image14%><%endif%> +<%if Image15%><%endif%> +<%if Image16%><%endif%> +<%if Image17%><%endif%> +<%if Image18%><%endif%> +<%if Image19%><%endif%> +<%if Image20%><%endif%> + +
          +
          +<%if Paragraph1%><%Paragraph1%><%endif%> +
          +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles, $ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + +<%-- + + + + + + + + + + +--%> \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo_large.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo_large.html new file mode 100644 index 0000000..ff76174 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_photo_large.html @@ -0,0 +1,278 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%Plugins::SlideShow::generate_paths($ID)%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + +<%--meta property="fb:admins" content="100001571171264,721935200,100004276806266" /--%> +<%--Twitter Meta Tags--%> + + + + + +<%if Image1_thumbnail_path%> + + + +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> + + + + +<%include include_common_head.html%> + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          + +<%-- +<%if next_url or prev_url%>

          <%if prev_url%>< Previous<%endif%><%if next_url and prev_url%> | <%endif%><%if next_url%>Next ><%endif%>

          <%endif%> +--%> + +

          + <%Title%><%if URL and URL ne 'http://'%> (Visit this link)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          +<%-- Hits: <%Hits%>
          --%> + Added: <%Add_Date%>
          + <%if Add_Date ne $Mod_Date%>Last Modified: <%Mod_Date%>
          <%endif%> +
          +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +
          +
          +<%if Paragraph1%><%Paragraph1%><%endif%> + +

          + +
          + +<%if Image1_description%><%Image1_description%>

          <%endif%> +<%if Image1%>


          <%endif%> + +<%if Image2_description%><%Image2_description%>

          <%endif%> +<%if Image2%>


          <%endif%> + +<%if Image3_description%><%Image3_description%>

          <%endif%> +<%if Image3%>


          <%endif%> + +<%if Image4_description%><%Image4_description%>

          <%endif%> +<%if Image4%>


          <%endif%> + +<%if Image5_description%><%Image5_description%>

          <%endif%> +<%if Image5%>


          <%endif%> + +<%if Image6_description%><%Image6_description%>

          <%endif%> +<%if Image6%>


          <%endif%> + +<%if Image7_description%><%Image7_description%>

          <%endif%> +<%if Image7%>


          <%endif%> + +<%if Image8_description%><%Image8_description%>

          <%endif%> +<%if Image8%>


          <%endif%> + +<%if Image9_description%><%Image9_description%>

          <%endif%> +<%if Image9%>


          <%endif%> + +<%if Image10_description%><%Image10_description%>

          <%endif%> +<%if Image10%>


          <%endif%> + +<%if Image11_description%><%Image11_description%>

          <%endif%> +<%if Image11%>


          <%endif%> + +<%if Image12_description%><%Image12_description%>

          <%endif%> +<%if Image12%>


          <%endif%> + +<%if Image13_description%><%Image13_description%>

          <%endif%> +<%if Image13%>


          <%endif%> + +<%if Image14_description%><%Image14_description%>

          <%endif%> +<%if Image14%>


          <%endif%> + +<%if Image15_description%><%Image15_description%>

          <%endif%> +<%if Image15%>


          <%endif%> + +<%if Image16_description%><%Image16_description%>

          <%endif%> +<%if Image16%>


          <%endif%> + +<%if Image17_description%><%Image17_description%>

          <%endif%> +<%if Image17%>


          <%endif%> + +<%if Image18_description%><%Image18_description%>

          <%endif%> +<%if Image18%>


          <%endif%> + +<%if Image19_description%><%Image19_description%>

          <%endif%> +<%if Image19%>


          <%endif%> + +<%if Image20_description%><%Image20_description%>

          <%endif%> +<%if Image20%>


          <%endif%> + +
          +
          +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles, $ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + +<%-- + + + + + + + + + + +--%> \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_video.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_video.html new file mode 100644 index 0000000..386c1ca --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_detailed_video.html @@ -0,0 +1,202 @@ + +<%Links::Utils::load_reviews($ID, $detailed_max_reviews)~%> +<%convert_nl_br%> + + <%Title%> - <%site_title_short%> +<%--Facebook Meta Tags--%> + + + + + + + + +<%--meta property="fb:admins" content="100001571171264,721935200,100004276806266" /--%> +<%--Twitter Meta Tags--%> + + + + + +<%if Thumbnail_URL and Thumbnail_URL ne 'http://' %> + + + +<%else%> + <% Plugins::ConvertVideo::get_file_path($ID, "thumbnail_file_field") %> + <%if thumbnail_file_field_path%> + + + + <%endif%> +<%endif%> +<%--End Facebook Meta Tags--%> +<%--End Twitter Meta Tags--%> +<%include include_common_head.html%> + + +<%include include_facebook_comments.html%> +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          + +

          + <%Title%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> +<%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> +<%~endif%> +

          + +<%if Votes~%> +

          + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) +

          +<%~endif%> + +

          + Written by: <%if LinkOwner ne 'admin'%><%endif%><%Contact_Name%><%if LinkOwner ne 'admin'%><%endif%>
          +<%-- Hits: <%Hits%>
          --%> + Added: <%Add_Date%>
          + <%if Add_Date ne $Mod_Date%>Last Modified: <%Mod_Date%>
          <%endif%> +
          +

          + +
          +
          +<%if URL and URL ne 'http://' %><%set video = $URL%><%endif%> +<%if Image_URL and Image_URL ne 'http://' %><%set image = $Image_URL%><%endif%> +<%if video%><%include include_video_player.html%><%endif%> +
          +
          +
          +<%if Paragraph1%><%Paragraph1%><%endif%> +
          +
          + +

          + <%--a href="<%config.db_cgi_url%>/review.cgi?ID=<%ID%>;add_review=1">Comment on this article + <%if user.Status eq 'Administrator'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Editor'%>EDIT THIS ARTICLE<%endif%> + <%if user.Status eq 'Administrator'%>Log Out<%endif%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if isLinkOwner%>Edit this link<%endif%> + <%if paymentsEnabled%><%if isUnpaid or isFree%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          + +
          + +

          +

          +<%--script type="text/javascript"> +tweetmeme_source = 'slowtwitch'; +
          +

          + +

          +

          +   +<%--Share +--%> +
          +

          + +
          + +
          + +
          + <%ad_300x250_roadblocks%> +
          + +
          + Articles related to this one + <%if RelatedArticles%> + + <%related_articles($RelatedArticles,$ID)%> + <%loop related_articles_loop%> + <%Plugins::SlideShow::generate_paths($ID)%><%rewrite_detail_url%> +
          + <% set tb = thumbnail($loop_value, $Image1_thumbnail_path) %> + <%if tb %>
          + +
          <%endif%> +
          + <%Title%>
          + <%Description%> <%GT::Date::date_transform($Add_Date,$config.date_user_format, '%m%.%dd%.%yy%')%> +
          +
          +
          + <%endloop%> + + <%elsif Related_Article1%> +

          <%Related_Article1%>

          + <%if Related_Article2%> +

          <%Related_Article2%>

          + <%endif%> + <%if Related_Article3%> +

          <%Related_Article3%>

          + <%endif%> + <%if Related_Article4%> +

          <%Related_Article4%>

          + <%endif%> + <%if Related_Article5%> +

          <%Related_Article5%>

          + <%endif%> + + <%else%> +

          There are no related articles

          + <%endif%> +
          + +
          + +
          + +<%if Review_Loop.length~%> +

          Comments

          + +<%--p class="reviewsheader">Add your own comment + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if Review_Total > $Review_Loop.length%>

          Read <%Review_Total%> comment<%if Review_Total != 1%>s<%endif%>

          <%endif%> +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_facebook_comments.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_facebook_comments.html new file mode 100644 index 0000000..dc79ddc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_facebook_comments.html @@ -0,0 +1,12 @@ +<% if ID == 5513 %> +
          +<%else%> +
          + +<%endif%> \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_footer.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_footer.html new file mode 100644 index 0000000..c810557 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_footer.html @@ -0,0 +1,71 @@ +
          + +<%--if in.debug%><%DUMP%><%endif--%> + + + +<%-- WALLPAPER AdBlock Code --%> + + + + +<%-- PEEL Code --%> + + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html new file mode 100644 index 0000000..763545c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html @@ -0,0 +1,260 @@ + +
          + +
          + +
          +
          +
          + +
          + <%~if config.db_gen_category_list == 2%> + + <%~set selected_cats = Links::Tools::category_list_selected%> + <%~loop selected_cats%> + + <%~endloop%> + +
          + + <%~elsif category_loop_selected%> + <%~if category_loop.length > 1%> +
            <%loop category_loop%>
          • <%Full_Name%>
          • <%endloop%>
          + <%~else%> + <%loop category_loop%><%Full_Name%><%endloop%> + <%~endif%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + <% if modify and Link_Type%> + + <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%> + <% else %> + + <% endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          style="display:none"<% endif %>> + +
          + +
          +
          +
          style="display:none"<%endif%>> + <% include include_form_video.html %> +
          +
          style="display:none"<%endif%>> + <% include include_form_article_photo.html %> +
          + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.120316 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.120316 new file mode 100644 index 0000000..aa9ac2b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.120316 @@ -0,0 +1,247 @@ + +
          + +
          + +
          +
          +
          + +
          + <%~if config.db_gen_category_list == 2%> + + <%~set selected_cats = Links::Tools::category_list_selected%> + <%~loop selected_cats%> + + <%~endloop%> + +
          + + <%~elsif category_loop_selected%> + <%~if category_loop.length > 1%> +
            <%loop category_loop%>
          • <%Full_Name%>
          • <%endloop%>
          + <%~else%> + <%loop category_loop%><%Full_Name%><%endloop%> + <%~endif%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + <% if modify and Link_Type%> + + <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%> + <% else %> + + <% endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          style="display:none"<% endif %>> + +
          + +
          +
          +
          style="display:none"<%endif%>> + <% include include_form_video.html %> +
          +
          style="display:none"<%endif%>> + <% include include_form_article_photo.html %> +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.bak2 new file mode 100644 index 0000000..8df096b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form.html.bak2 @@ -0,0 +1,275 @@ +
          + +
          + +
          +
          +<%-- +
          + +
          + +
          +
          +--%> +
          + +
          + <%~if config.db_gen_category_list == 2%> + + <%~set selected_cats = Links::Tools::category_list_selected%> + <%~loop selected_cats%> + + <%~endloop%> + +
          + + <%~elsif category_loop_selected%> + <%~if category_loop.length > 1%> +
            <%loop category_loop%>
          • <%Full_Name%>
          • <%endloop%>
          + <%~else%> + <%loop category_loop%><%Full_Name%><%endloop%> + <%~endif%> + <%~else%> + + <%~endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          +
          + + +
          +
          + Image #1: +
          +
          +
          +
          + Image #2: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #3: +
          +
          +
          +
          + Image #4: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #5: +
          +
          +
          +
          + Image #6: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #7: +
          +
          +
          +
          + Image #8: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #9: +
          +
          +
          +
          + Image #10: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #11: +
          +
          +
          +
          + Image #12: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #13: +
          +
          +
          +
          + Image #14: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #15: +
          +
          +
          +
          + Image #16: +
          +
          + + +
          +
          + +
          + +
          + +
          +
          + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_article_photo.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_article_photo.html new file mode 100644 index 0000000..c293cc3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_article_photo.html @@ -0,0 +1,268 @@ +<% set show_photo = 0 %> +<% if Link_Type eq 'photo' %> +<% set show_photo = 1 %> +<% endif %> +
          style="display:none"<% endif %>> + +
          + +
          +
          +
          style="display:none"<% endif %>> + +
          + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #1: +
          +
          +
          +
          + Image #2: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #3: +
          +
          +
          +
          + Image #4: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #5: +
          +
          +
          +
          + Image #6: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #7: +
          +
          +
          +
          + Image #8: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #9: +
          +
          +
          +
          + Image #10: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #11: +
          +
          +
          +
          + Image #12: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #13: +
          +
          +
          +
          + Image #14: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          + Image #15: +
          +
          +
          +
          + Image #16: +
          +
          style="display:none"<% endif %>> + + +
          +
          style="display:none"<% endif %>> + + +
          +
          +
          style="display:none"<% endif %>> +
          +
          + + +
          +
          + Image #17: +
          +
          +
          +
          + Image #18: +
          +
          + + +
          +
          +
          +
          + + +
          +
          + Image #19: +
          +
          +
          +
          + Image #20: +
          +
          + + +
          +
          +
          \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_video.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_video.html new file mode 100644 index 0000000..b14c8df --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_form_video.html @@ -0,0 +1,65 @@ +<%~if File_Path%> +<%set selectfile = 1 %> +<% else %> +<%set selectfile = 0 %> +<%endif~%> +
          + +
          + checked<%endif%> value="website"> + checked<%endif%> value="file"> +
          +
          +
          style="display:none"<%endif%>> +
          + +
          + +
          +
          +
          + +
          + <%if Image_Path%> <%Image_Path%><%endif%> +
          +
          +
          +
          style="display:none"<%endif%>> +
          + +
          + <%if File_Path%> <%File_Path%><%endif%> +
          +
          +
          + +
          + + +
          Select this checkbox if you want to generate the associated video files (for example, image file, flash file) while uploading the video file. This process may take several minutes.
          +
          +
          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_header.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_header.html new file mode 100644 index 0000000..92a2c28 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_header.html @@ -0,0 +1,49 @@ + + + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_leftsidebar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_leftsidebar.html new file mode 100644 index 0000000..da1f268 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_leftsidebar.html @@ -0,0 +1,25 @@ +<%-- Note that this left sidebar is not displayed by default. See the examples in static/luna/luna.css on how to display the sidebar. --%> + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar.html new file mode 100644 index 0000000..0f52f3a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar.html @@ -0,0 +1,59 @@ + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar_sidenav.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar_sidenav.html new file mode 100644 index 0000000..bac02dc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_rightsidebar_sidenav.html @@ -0,0 +1,46 @@ + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_stack_reach_content.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_stack_reach_content.html new file mode 100644 index 0000000..0928c05 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_stack_reach_content.html @@ -0,0 +1,5233 @@ +

          2011 INDUSTRY DATABASE
          + (to be updated until all relevant tri bikes are included)

          +

          Manufacturers are listed below alphabetically. Click on an entry to jump to that manufacturer. Each table below contains the company's stack & reach measures, per size, along with other relevant data. Click here for a primer on stack & reach sizing.

          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          ARGON18BLUEBH
          BMCCALFEECANNONDALE
          CEEPOCERVELOELITE
          FELTFOCUSFUJI
          GIANTJAMISKESTREL
          KUOTALEADERLOOK
          ORBEAPARLEEPLANET X
          QUINTANA ROORIDLEYSCOTT
          SPECIALIZEDTITANFLEXTREK
          VALDORAWILIER
          +
          +To help explain and expand on these tables, please consider the reading below: +
          +

          NOTES ON THE STACK & REACH TABLE
          + FIXING BAD CENTER-OF-MASS THROUGH CUSTOM GEOMETRY
          + HEADSETS AND SPACERS
          + WEB RESOURCES

          +
          +

          NOTES ON THE STACK & REACH TABLE
          +

          + - All stack and reach measures are taken from the center of the bottom bracket to the top of the head tube, midway between its fore and aft termini. There will probably be a few millimeters of headset cap to add, and this will slightly change per each manufacturer. If the headset is external you'll need to account for this, and we explain how to do this below.
          +
          + - The seat angle is listed because of the common occurence of proprietary aero seat tube/post complexes that cannot be swapped for aftermarket posts. Keep in mind that at best you're looking at 2 degrees of adjustability fore and aft (4 degrees total) through moving the saddle fore and aft (excepting 2-position seat posts and the Giant's post, the clamp of which sits on a set of "ways." So, if your customer needs 80 degrees and the bike is built at 76.5, or needs 76 degrees and the bike is built at 79, you'll probably need to look for another bike if the post is unswappable.
          +
          + - The front/center measure is included not because of any issue of fit, but of handling. If the rider chooses a somewhat steep configuration, you'll want some extra front/center for the purpose of achieving a better weight distribution.

          +
          FIXING BAD CENTER-OF-MASS USING CUSTOM GEOMETRY
          +
          +
          +

          If a rider's center of mass is either too far forward on the bike, or too high above the bike, the best way to fix this on a tri bike is usually to increase the bike's front center. This is explained a bit in our article on short-torsoed riders. The chart below will give you some idea of the change in the bike's front/center you get by shallowing the head angle a half-degree combined with an increase in the fork's offset so as to achieve the same trail. In this case, I'm using certain given wheel radii for 650c and 700c that are subject to change, based on the profile of the tire you use. I'm also arbitrarity choosing an amount of trail typical (but not universal) in tri bike design. As you see, you'll add about 1.5cm of front/center for every degree you slacken the head angle.
          +
          +

          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          650c (315mm tire radius)
          +
          +
          Head angle
          +
          +
          Offset
          +
          +
          trail
          +
          +
          Change in F/C
          +
          +
          74.0
          30
          59.1
          Baseline
          73.5
          33
          58.9
          add .75cm versus baseline
          73.0
          36
          58.7
          add 1.5cm versus baseline
          72.5
          39
          58.4
          add 2.3cm versus baseline
          72.0
          41
          59.2
          add 3.0cm versus baseline
              
          700c (336mm tire radius)
          +
          +
          74.0
          36
          58.9
          Baseline
          73.5
          39
          58.9
          add .75cm versus baseline
          73.0
          42
          58.8
          add 1.5cm versus baseline
          72.5
          45
          58.8
          add 2.2cm versus baseline
          72.0
          48
          58.7
          add 2.9cm versus baseline
          71.5
          51
          58.6
          add 3.7cm versus baseline
          71.0
          54
          58.6
          add 4.5cm versus baseline
          +
          +
          +

          My purpose in highlighting the above relates to the long-legged, short-torsoed athlete described here. In this case, it's often observed that the rider's center of mass sits too high above the ground relative to the wheelbase of that rider's bike, should he be fitted on a bike that corresponds to his cockpit distance. This is more problematic in triathlon than it is in road race, because of the problematic weight displacement steep-angled riders face, and because the "pursuit" position tends to place the rider higher than the road rider's hooks position. Should the rider want to keep his position intact, and should the fitter/designer want to keep his steering geometry intact, the best fix is to add front/center. The table above roughly quantifies the delta when executing that change.
          +

          +
          +
          +

          ACCOUNTING FOR EXTERNAL HEADSETS AND SPACERS

          +
          +
          +

          A frame's stack & reach are calculated to the head tube top. What of bikes that use external headsets? (also see integrated headsets.) How do you account for this? You can't simply say, "Add 2cm of stack," because the steering axis isn't 90 degrees, it's positioned at 72 degrees or thereabouts. Plus, if you're adding spacers into the mix, you must account for these. Let us say your proposed bike uses an external headset plus you'll want 1.5cm of spacers underneath the stem. Most headsets average about 2cm in stack above the head tube top. So you've got 3.5cm to account for.
          +
          + The sine of 72 degrees is very close to Sine. The cosine of 72 degrees is very close to Cosine. These numbers are good enough to use for every head angle, because you're looking for precision within 1mm or 2mm, nothing more. So, in the case of 3.5cm of "angled stack," you multiply this times the sine and cosine of 72 degrees, and you get 3.3cm and 1.1cm respectively.
          +
          + Let's try an example. Let's say that your fit simulator, with stem right down on the simulator's plate (analogous to your stem sitting right on your head tube top), shows you need a frame with a stack and reach of 58.7cm and 43.5cm respectively. Let's say you're considering a Calfee for your customer. You have to account for the Calfee's external headset. This headset, plus perhaps 1.5cm of spacers you might want under the stem, is that 3.5cm of "angled stack" described above. This 3.5cm of stack "angled back" at 73 degrees drives the stack of the frame you'll need down 3.3cm (3.5cm x sine73 = 3.3cm). So the frame's stack you'll need is really 54.4cm, not 58.7cm. This 3.5cm of stuff above the head tube top "shortens" the rider's cockpit by 3.5cm x cosine(73) = 1.1cm. So the actual reach you'll need on your hoped-for Calfee is 44.6cm instead of 43.5cm.
          +
          + So now you're looking for a frame with a stack and reach of 54.4cm and 44.6cm respectively, not the 58.7cm and 43.5cm you thought you'd need prior to accounting for the "stuff" above the head tube. Calfee offers a production geometry with a 54.7cm and 44.5cm stack and reach, its 58cm tri bike in 700c. Assuming you outfit this frame with the same length and pitch of stem, and same aerobars, as you're using on the fit simulator, take out a 5mm spacer and sub-in a 2mm spacer, and you'll replicate the fit achieved on the simulator to within 1mm.
          +
          + INTEGRATED HEADSETS: Keep in mind that the bike's published stack must often be added to, because there are head parts that rise above the head tube top even with integrated headsets. This may be 2mm, and it may be 10mm and more.

          +
          +
          +

          WEB RESOURCES

          +
          +
          +

          There are plenty of good (and even free) resources on the web. The best (that I've found) among the parametric programs that would aid a framebuilder or designer is an Excel-based framebuilding tool by Martin Manning, called Body Geometry 101. Note you'll have to register to join the Framebuilders Forum in order to find and download it.

          +
          +
          +
          +
          +

          STACK & REACH TABLES

          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          ARGON18
          XS
          48.5
          39.8
          700C
          int
          80
          6.5/8.5*
          Low
          76/78
          577
           
          S
          49.5
          41.1
          700C
          int
          90
          6.5/8.5*
          Low
          76/78
          594
          E-114
          M
          51.5
          41.9
          700C
          int
          110
          6.5/8.5*
          Low
          76/78
          607
          E-112
          L
          53.6
          42.8
          700C
          int
          135
          6.5/8.5*
          Low
          76/78
          622
                     
           
          XS
          49.9
          39.1
          700C
          Int
             
          76/78
          577
          MERCURY
          S
          49.9
          40.8
          700C
          Int
             
          76/78
          594
           
          M
          51.9
          41.5
          700C
          Int
             
          76/78
          607
           
          L
          53.6
          42.5
          700C
          Int
             
          76/78
          622
          *The E-114 features the ONEness Concept integrated stem and aerobars.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          BLUE
          XS
          49.1
          36.4
          700C
          int
          95
          N/A
          N/A
          76-79
          559
           
          S
          50.5
          37.2
          700C
          int
          103
          N/A
          N/A
          76-79
          554
          T14
          M
          51.3
          39.5
          700C
          int
          111
          N/A
          N/A
          76-79
          580
           
          ML
          52.6
          40.7
          700C
          int
          125
          N/A
          N/A
          76-79
          595
           
          L
          55.0
          42.2
          700C
          int
          150
          N/A
          N/A
          76-78
          616
           
          XL
          57.2
          42.6
          700C
          int
          173
          N/A
          N/A
          76-78
          629
                     
          SM
          52.0
          37.8
          700C
          int
          100
          N/A
          N/A
          76-79
          56.5
           
          MD
          53.9
          39.8
          700C
          int
          120
          N/A
          N/A
          76-79
          59.1
          Triad
          ML
          55.8
          41.4
          700C
          int
          140
          N/A
          N/A
          76-79
          61.2
           
          LG
          57.7
          42.9
          700C
          int
          160
          N/A
          N/A
          76-79
          63.3
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          BH
          52
          520
          390
          700C
          int
          110
            
          74-78
          N/A
           
          54
          536
          406
          700C
          int
          130
            
          74-78
          N/A
          GC AERO
          56
          560
          420
          700C
          int
          150
            
          74-78
          N/A
           
          58
          579
          432
          700C
          int
          170
            
          74-78
          N/A
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          BMC
          S
          480
          393
          700C
          int
          *
           
          77
          590
           
          M-S
          515
          377
          700C
          int
          *
           
          77
          583
          TM01
          M-L
          515
          418
          700C
          int
          *
           
          77
          624
           
          L
          556
          442
          700C
          int
          *
           
          77
          661
          *The TM01 uses a proprietary stem setup
          All sizes have a trail of 60.2mm
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          CALFEE
          46
          45.7
          37.8
          650C
          ext
          91
          **
          **
          77.0
          55.3
           
          48
          46.3
          40.3
          650C
          ext
          91
          **
          **
          77.0
          56.8
           
          50
          47.2
          41.9
          650C
          ext
          100
          **
          **
          77.0
          58.7
           
          52
          48.4
          42.5
          650C
          ext
          113
          **
          **
          77.0
          59.7
          54
          49.8
          43.6
          650C
          ext
          128
          **
          **
          76.5
          61.2
          ALL
          56
          51.9
          45.0
          650C
          ext
          150
          **
          **
          76.5
          63.2
          56
          54.2
          44.0
          700C
          ext
          128
          **
          **
          76.5
          64.0
          58
          53.3
          45.4
          650C
          ext
          160
          **
          **
          76.5
          64.0
          58
          54.7
          44.9
          700C
          ext
          133
          **
          **
          76.0
          65.0
          60
          54.8
          46.5
          650C
          ext
          180
          **
          **
          76.0
          65.6
          60
          57.0
          46.1
          700C
          ext
          165
          **
          **
          76.0
          67.0

          + ** Each of Calfee's bikes have stem and bar spec'd by the dealer prior to shipping
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          CANNONDALE
          47
          47.8
          36.5
          650C
          int
          103
          73/78
          556
           
          51
          49.4
          37.1
          700C
          int
          90
          73/78
          565
          SLICE ULTIMATE
          54
          50.9
          39.8
          700C
          int
          105
          73/78
          596
          1, 3, & 5
          56
          52.9
          40.7
          700C
          int
          125
          73/78
          607
          58
          54.8
          41.7
          700C
          int
          145
          73/78
          623
           
          60
          57.2
          42.5
          700C
          int
          170
          73/78
          639
                     
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          CEEPO
          M
          516
          407
          700C
          int
          110
            
          78
          588
          VIPER
          L
          535
          434
          700C
          int
          130
            
          77
          620
            
          S
          456
          410
          650C
          int
          100
            
          78
          582
          KATANA
          S
          493
          405
          700C
          int
          90
            
          78
          592
           
          M
          513
          409
          700C
          int
          110
            
          77
          598
           
          L
          534
          432
          700C
          int
          130
            
          76
          611
                     
          S
          493
          412
          700C
          int
          90
            
          78
          599
          VENOM
          M
          517
          413
          700C
          int
          110
            
          77
          598
           
          L
          534
          434
          700C
          int
          130
            
          77
          625
           
          XL
          562
          437
          700C
          int
          160
            
          76
          638
                     
          S
          494
          405
          700C
          int
          90
            
          78
          587
          STINGER
          M
          513
          409
          700C
          int
          110
            
          77
          598
           
          L
          534
          420
          700C
          int
          130
            
          76
          611
                     
          GRACE
          S
          494
          405
          700C
          int
          90
            
          78
          587
          M
          513
          409
          700C
          int
          110
            
          77
          598
                     
          S
          509
          400
          700C
          int
          110
            
          76
          574
          MAMBA
          M
          530
          404
          700C
          int
          130
            
          75
          582
           
          L
          549
          410
          700C
          int
          150
            
          74
          587
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          CERVELO
          48
          46.1
          38.9
          650C
          int
          110
          70x6
          Low
          75/78
          568
           
          51
          48.2
          40.5
          700C
          int
          90
          70x6
          Low
          75/78
          586
          P3
          54
          49.8
          41.9
          700C
          int
          105
          90x6
          Low
          75/78
          609
          P4
          56
          51.6
          43.3
          700C
          int
          125
          90x6
          Low
          75/78
          626
           
          58
          53.5
          44.5
          700C
          int
          145
          110x6
          Low
          75/78
          643
           
          61
          56.4
          45.4
          700C
          int
          175
          110x6
          Low
          75/78
          659
                     
           
          48
          46.1
          38.9
          650C
          int
          110
          70x6
          Low
          75/78
          568
          P2
          51
          48.2
          40.5
          700C
          int
          90
          70x6
          Low
          75/78
          586
          P1
          54
          51.2
          41.8
          700C
          int
          120
          90x6
          Low
          75/78
          609
           
          56
          53.1
          42.9
          700C
          int
          140
          90x6
          Low
          75/78
          626
           
          58
          55.0
          44.0
          700C
          int
          160
          110x6
          Low
          75/78
          643
           
          61
          57.7
          44.7
          700C
          int
          180
          110x6
          Low
          75/78
          659
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          ELITE
          XS
          46.25
          35.5
          650C
          ext
          96
          **x6
          High
          78.0
           
           
          S
          49.0
          37.0
          650C
          ext
          115
          **x6
          High
          77.5
           
           
          S
          48.0
          37.0
          700C
          ext
          60
          **x6
          High
          78.0
           
          T CLASS
          MS
          50.5
          38.5
          700C
          ext
          80
          **x6
          High
          77.5
           
           
          M
          52.0
          41.0
          700C
          ext
          100
          **x6
          High
          77.0
           
           
          L
          54.0
          44.0
          700C
          ext
          120
          **x6
          High
          76.5
           
           
          XL
          57.5
          44.0
          700C
          ext
          165
          **x6
          High
          76.0
           
           

          + NOTE: Customer specs stem length, but pitch is 6 degrees. Aerobar is Easton, lower profile adjustability is available.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          FELT
          48
          46.5
          37.0
          650C
          int
          115
          60x0
          Low
          80/78
          562
           
          50
          48.5
          39.0
          650C
          int
          130
          80x0
          Low
          80/78
          568
          DA
          52
          50.0
          40.5
          700C
          int
          100
          90x0
          Low
          80/78
          589
          B2
          54
          51.0
          41.5
          700C
          int
          110
          100x0
          Low
          78/76
          596
          S22
          56
          52.5
          42.5
          700C
          int
          125
          100x0
          Low
          78/76
          612
          S32
          58
          54.5
          45.0
          700C
          int
          145
          110x0
          Low
          78/76
          640
           
          60
          56.0
          46.0
          700C
          int
          160
          110x0
          Low
          79/77
          657
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          FOCUS
          S
          480.4
          397.7
          700C
          INT
          95
          76.3-77
          M
          505.1
          428.7
          700C
          INT
          100
          76.3-77
          Chrono AMP
          L
          505.1
          453.7
          700C
          INT
          100
          76.3-77
          S
          500.2
          366.5
          700C
          INT
          75
          Izalco Tria
          M
          511.0
          388.1
          700C
          INT
          75
          L
          535.2
          406.6
          700C
          INT
          75
           XL559.5425.5700CINT   
          75
           
          47
          501.2
          390.1
          700C
          INT
          75
          Variardo Tria
          50
          504.3
          404.3
          700C
          INT
          100
          75
           
          53
          525.9
          409.1
          700C
          INT
          120
          75
           
          56
          553.7
          416.9
          700C
          INT
          150
          75
           
          59
          582.4
          434.8
          700C
          INT
          180
          75
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          FUJI
          XS
          481
          354
          700C
          int
          80
          76
           
          S
          490
          372
          700C
          int
          90
          76
          D6
          S/M
          500
          390
          700C
          int
          100
          76
          M
          509
          402
          700C
          int
          110
          76
          M/L
          525
          424
          700C
          int
          120
          76
          L
          525
          445
          700C
          int
          120
          76
           
          XL
          538
          460
          700C
          int
          140
          76
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
                     
          GIANT
          XS
          50.3
          39.7
          700C
          int
          100
          90x6
          High
          78.0
          59.0
           
          S
          51.7
          41.0
          700C
          int
          115
          90x6
          High
          78.0
          60.7
          TRINITY ALLIANCE
          M
          53.3
          42.7
          700C
          int
          130
          100x6
          High
          78.0
          62.9
          TRINITY
          L
          54.8
          44.9
          700C
          int
          145
          110x6
          High
          78.0
          65.0
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          JAMIS
          Small
          496
          405
          700C
          int
          100
          *
          *
          78
           
           
          Medium
          509
          417
          700C
          int
          110
          *
          *
          78
           
          XENITH
          MedLrg
          531
          432
          700C
          int
          130
          *
          *
          78
           
          T1/T2
          Large
          556
          457
          700C
          int
          160
          *
          *
          78
           
           
          51
          493
          402
          700C
          int
          100
           
          high
          78
           
           
          54
          506
          415
          700C
          int
          110
           
          high
          78
           
          TRILOGY
          56
          525
          430
          700C
          int
          130
           
          high
          78
           
           
          58
          539
          447
          700C
          int
          145
           
          high
          78
           
           
          61
          553
          454
          700C
          int
          160
           
          high
          78
           
           
          51
          493
          402
          700C
          int
          100
           
          high
          78
           
           
          54
          506
          415
          700C
          int
          110
           
          high
          78
           
          COMET
          56
          525
          431
          700C
          int
          130
           
          high
          78
           
           
          58
          539
          447
          700C
          int
          145
           
          high
          78
           
           
          61
          554
          454
          700C
          int
          160
           
          high
          78
           
          *NOTE: The T1 features high profile Profile T2 Cobras with a 6° stem. The T2 features low profile Easton Attack TT bars with a 10° stem.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          KESTREL
          47
          437
          399
          650C
          int
          76
          90x6
          High
          78.0
          563
           
          50
          466
          409
          650C
          int
          105
          90x6
          High
          77.5
          579
           
          52
          484
          415
          650C
          int
          123
          90x6
          High
          77.0
          589
          AIRFOIL PRO
          54
          503
          426
          700C
          int
          92
          100x6
          High
          76.5
          607
           
          56
          521
          431
          700C
          int
          113
          100x6
          High
          76.0
          616
           
          59
          550
          439
          700C
          int
          142
          110x6
          High
          76.0
          630
                     
           
          47
          467
          397
          650C
          int
          105
            
          76.5
          567
          4000
          50
          525
          394
          700C
          int
          115
            
          76.5
          687
           
          525
          530
          403
          700C
          int
          120
            
          76.0
          595
           
          55
          536
          418
          700C
          int
          125
            
          76.0
          609
           
          575
          541
          440
          700C
          int
          130
            
          76.0
          633
           
          595
          547
          450
          700C
          int
          135
            
          76.0
          642
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          KUOTA
          48
          49.6
          39.0
          700C
          int
          95
            
          79
          58.2
           
          51
          49.6
          41.1
          700C
          int
          95
            
          79
          60.0
          KUEEN-K
          54
          50.5
          42.4
          700C
          int
          105
            
          79
          61.6
           
          56
          51.5
          43.9
          700C
          int
          115
            
          79
          63.3
           
          58
          53.4
          45.4
          700C
          int
          135
            
          79
          63.4
                     
           
          S
          49.8
          39.6
          700C
          int
          95
          90x6
          High
          76
          58.6
           
          M
          50.8
          41.1
          700C
          int
          105
          90x6
          High
          76
          60.4
          KALIBUR
          L
          52.3
          42.8
          700C
          int
          120
          100x6
          High
          76
          61.8
           
          XL
          54.2
          43.9
          700C
          int
          140
          1100x6
          High
          76
          63.4
                     
           
          S
          52.7
          38.7
          700C
          int
          125
          70x6
          High
          76
          58.6
           
          M
          53.6
          40.2
          700C
          int
          135
          70x6
          High
          76
          60.4
          K-FACTOR
          L
          55.2
          41.9
          700C
          int
          150
          90x6
          High
          76
          61.8
           
          XL
          56.0
          43.9
          700C
          int
          160
          90x6
          High
          76
          63.4

          + The Kalibur's standard aerobar is Profile Design, hence the "high" profile designation. This model does, however, have HED as an aerobar option, which would be designated as having "low" profile armrests.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          LEADER
          50
          50.0
          39.0
          700C
          int
           
          *
          *
          78
          57.0
           
          54
          51.0
          42.0
          700C
          int
           
          *
          *
          78
          60.4
          LD735TT
          57
          52.0
          43.0
          700C
          int
           
          *
          *
          78
          62.0
           
          60
          55.0
          44.5
          700C
          int
           
          *
          *
          78
          64.5
           
          63
          58.0
          45.5
          700C
          int
          *
          *
          78
          66.0
                     
           
          50
          50.9
          39.6
          700C
          int
           
          *
          *
          78
          57.8
          LD720TT
          54
          51.0
          42.6
          700C
          int
           
          *
          *
          78
          60.8
          LD780TT
          57
          52.8
          43.7
          700C
          int
           
          *
          *
          78
          62.5
           
          60
          55.7
          45.1
          700C
          int
           
          *
          *
          78
          64.7
           
          63
          58.5
          45.9
          700C
          int
          *
          *
          78
          66.4

          + *NOTE: Leader sells their bikes as bare frames only - no fork, headset, or seatpost is included.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          LOOK
          XS-HI
          476.0
          386.3
          700C
          int
          75
          574
           
          XS-LO
          461.6
          390.7
          700C
          int
          75
          574
           
          S-HI
          477.6
          403.2
          700C
          int
          75
          587
           
          S-LO
          463.2
          407.6
          700C
          int
          75
          587
          596*
          M-HI
          523.7
          409.8
          700C
          int
          75
          600
          M-LO
          509.3
          414.2
          700C
          int
          75
          600
          L-HI
          523.7
          425.5
          700C
          int
          75
          615
          L-LO
          509.3
          429.9
          700C
          int
          75
          615
          *The 596 features the integrated monoblade front end. The integrated stem can be positioned in one of two places - either "hi" or "low." These positions, because of the stem mounting position on the Monoblade, affect the stack and reach. We have made stack and reach assumptions based around a parrallel stem (approx. -17deg stem orientation), as unlike a "normal" frame, the bottom of the stem is not at the top of the headset spacer.
                     
           
          S
          522
          387
          700C
          int
          125
          78
          580
           
          MD
          547
          401
          700C
          int
          151
          78
          600
          576
          LG
          561
          429
          700C
          int
          166
          78
          632
           
          XL
          580
          450
          700C
          int
          186
          78
          654
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          ORBEA
          48
          497
          375
          700C
          int
          90
          74/76/78
           
          51
          512
          395
          700C
          int
          95
          74/76/78
          ORDU
          54
          520
          409
          700C
          int
          104
          74/76/78
          ORA
          57
          530
          422
          700C
          int
          111
          74/76/78
                     
           
          XS
          506
          385
          700C
          int
          95
          76
           
          S
          527
          400
          700C
          int
          115
          76
          ALETTA
          M
          542
          412
          700C
          int
          130
          76
           
          L
          558
          429
          700C
          int
          145
          76
           
          XL
          598
          429
          700C
          int
          185
          76
                     
           
          XS
          509
          375
          700C
          int
          100
          76
          ALETTA DAMA
          S
          530
          380
          700C
          int
          120
          76
           
          M
          546
          391
          700C
          int
          135
          76
          +
          +
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          PARLEE
          S-LO
          495
          385
          700C
          int
          90
          75-80
           
          S-HI
          514
          379
          700C
          int
          110
          75-80
          TT
          M-LO
          505
          403
          700C
          int
          100
          75-80
           
          M-HI
          524
          397
          700C
          int
          120
          75-80
           
          ML-LO
          524
          419
          700C
          int
          120
          75-80
           
          ML-HI
          543
          413
          700C
          int
          140
          75-80
           
          L-LO
          543
          435
          700C
          int
          140
          75-80
           
          L-HI
          562
          429
          700C
          int
          160
          75-80
           
          XL-LO
          562
          451
          700C
          int
          160
          75-80
           
          XL-HI
          581
          445
          700C
          int
          180
          75-80
                     

          + The Parlee TT comes with two different headtube lengths for each size. Due to negative reach, the different headtube lengths change both the stack and reach of the size. We've designated the shorter headtube as the "LO" sub-size and the taller headtube as the "HI" sub-size.
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          PLANET X
          XS
          475
          380
          650C
          int
           
          S
          490
          396
          700C
          int
          95
          76
          570
          STEALTH
          M
          506
          407
          700C
          int
          100
          76
          591
          L
          523
          418
          700C
          int
          120
          76
          612
          XL
          536
          429
          700C
          int
          130
          76
          632
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          QR
          XS
          453
          393
          650C
          int
          10
          78
          572
          2011 KILO
          S
          502
          388
          700C
          int
          10
          78
          577
          LUCERO
          M
          527
          403
          700C
          int
          12.5
          78
          605
          SEDUZA
          L
          568
          424
          700C
          int
          16.8
          78
          639
                     
           
          S
          497
          396
          650C
          int
          9
          78.5
          589
          CD0.1
          M
          497
          420
          700C
          int
          9
          78.6
          613
           
          ML
          517
          438
          700C
          int
          11
          78.5
          636
           
          L
          545
          452
          700C
          int
          14
          78.5
          659
                     
          46
          45.0
          38.0
          650C
          int
          90
          90x5
          Low
          78.5
          555
          2010
          49
          50.0
          40.0
          700C
          int
          90
          90x5
          Low
          78.5
          592
          TEQUILO
          52
          50.0
          42.0
          700C
          int
          90
          100x5
          Low
          78.5
          611
          AND PRIOR  
          55
          51.7
          43.5
          700C
          int
          110
          100x5
          Low
          78.5
          634
           
          58
          55.0
          44.8
          700C
          int
          140
          110x5
          Low
          78.5
          657
           
          61
          57.8
          46.1
          700C
          int
          165
          110x5
          Low
          78.5
          680
                     
          2010 DULCE
          XS
          453
          394
          650C
          int
          10
          78
          572
          SEDUZA
          S
          486
          388
          700C
          int
          8.5
          77
          577
          CALIENTE
          M
          514
          407
          700C
          int
          11
          77
          605
          LUCERO AND PRIOR
          L
          550
          430
          700C
          int
          15
          76.5
          639
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          RIDLEY
          XS
          490.6
          397.7
          700C
          int
          90
          76/78.5
          585
           
          S
          501.7
          414.9
          700C
          int
          100
          76/78.5
          598
          DEAN
          M
          520.9
          430.1
          700C
          int
          120
          76/78.5
          618.9
          L
          535.2
          447
          700C
          int
          135
          76/78.5
          639
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          SPECIALIZED
          Small
          50.5
          38.0
          700C
          int
          100
          75x8
          *
          *
          57.5
           
          Medium
          51.6
          39.5
          700C
          int
          110
          75x8
          *
          *
          58.9
          TRANSITION 2009 (all submodels)
          Large
          52.6
          40.5
          700C
          int
          120
          90x8
          *
          *
          60.2
           
          XLarge
          52.7
          42.5
          700C
          int
          120
          100x8
          *
          *
          62.1
                     
          XSmall
          487
          365
          700C
          int
          90
          75x8
          *
          *
          577
          Small
          505
          380
          700C
          int
          100
          90x8
          *
          *
          575
           
          Medium
          516
          395
          700C
          int
          110
          100x8
          *
          *
          589
          TRANSITION 2010 (all submodels)
          Large
          526
          405
          700C
          int
          120
          110x8
          *
          *
          602
           
          XLarge
          542
          421
          700C
          int
          135
          120x8
          *
          *
          621
          XXLarge
          554
          450
          700C
          int
          150
          120x8
          *
          *
          652
                     
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          SCOTT
          XS
          50.4
          37.9
          700C
          int
          100
          90x8
          High
          76.0
          58.1
           
          S
          51.5
          39.2
          700C
          int
          110
          90x8
          High
          76.0
          59.3
          PLASMA I & II
          M
          52.7
          40.4
          700C
          int
          120
          110x8
          High
          76.0
          60.4
           
          L
          54.8
          41.6
          700C
          int
          140
          110x8
          High
          76.0
          61.8
           
          XL
          58.1
          42.7
          700C
          int
          175
          120x8
          High
          76.0
          64.0
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          TITANFLEX
          S
          472
          398
          650C
          ext
          110
          75-84
          576
           
          M
          472
          446
          650C
          ext
          110
          75-84
          624
          AL-Ti
          M
          516
          379
          700C
          ext
          110
          72.5-81
          564
           
          L
          536
          407
          700C
          ext
          130
          72.5-81
          599
           
          SL
          536
          432
          700C
          ext
          130
          72.5-81
          624
           
          XL
          579
          418
          700C
          ext
          175
          73-81
          623
                     
           
          M
          472
          411
          650C
          ext
          110
          74-81
          589
          TRANSITION
          M
          516
          379
          700C
          ext
          110
          72.5-81
          564
           
          L
          536
          422
          700C
          ext
          130
          72.5-81
          614
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          TREK
          XS*
          468
          370
          650C
          int
          101
          50/10
          **
          78
          549
          S
          492
          390
          700C
          int
          76
          60/45
          **
          78
          575
          SPEED CONCEPT
          M
          517
          408
          700C
          int
          101
          100/45
          **
          78
          598
          9-series
          L
          541
          426
          700C
          int
          127
          100/45
          **
          78
          624
           
          XL
          565
          445
          700C
          int
          152
          100/45
          **
          78
          650


          + * The XS size is available in all models except the SpeedConcept 9.9.
          + ** The SpeedConcept 9-series features an adjustable stack-height aerobar

          XS
          468
          370
          650C
          int
          101
          60x7
          High
          78
          549
          S
          492
          390
          700C
          int
          76
          70x7
          High
          78
          575
          SPEED CONCEPT
          M
          517
          408
          700C
          int
          101
          80x7
          High
          78
          598
          7-series
          L
          541
          426
          700C
          int
          127
          90x7
          High
          78
          624
           
          XL
          565
          445
          700C
          int
          152
          90x7
          High
          78
          650
                     
           
          S
          51.5
          39.1
          700C
          int
          105
          70x12
          High
          75/77
          573.8
          EQUINOX TTX (all)
          M
          52.4
          41.9
          700C
          int
          115
          70x12
          High
          75/77
          604.1
           
          L
          56.4
          42.9
          700C
          int
          155
          70x12
          High
          75/77
          626.1
                     
           
          50
          48.5
          38.9
          700C
          int
          78
          70x7
          High
          76
          570.3
           
          52
          50.5
          40.0
          700C
          int
          97
          80x7
          High
          76
          582.4
          EQUINOX 7
          54
          52.6
          41.4
          700C
          int
          116
          90x7
          High
          76
          599.1
           
          56
          54.4
          42.0
          700C
          int
          136
          100x7
          High
          76
          610.1
           
          58
          56.4
          43.5
          700C
          int
          156
          110x7
          High
          76
          631.1
           
          60
          59.1
          44.8
          700C
          int
          186
          120x7
          High
          76
          652.6
                     
           
          47
          48.5
          38.0
          700C
          int
          7.8
          70x7
          High
          76
          560.4
          EQUINOX 7 WSD
          51
          51.8
          38.1
          700C
          int
          11.3
          80x7
          High
          76
          572.8
           
          54
          54.8
          38.81
          700C
          int
          14.1
          90x7
          High
          76
          580.6
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          VALDORA
          S
          54.6
          40.3
          700C
          int
          130
           
           
          76
          59.6
          PHX
          M
          56.6
          42.7
          700C
          int
          150
           
           
          76
          62.1
           
          L
          58.7
          44.6
          700C
          int
          170
           
           
          76
          64.0
                     
          +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
           
          Size
          Stack
          Reach
          Wheel
          HS
          HT
          Stem
          Hbars
          SA
          Ft/Ctr
          WILIER
          S
          498.6
          401.5
          700C
          int
          90
           
           
          76.5
          585.0
          CENTO CRONO
          M
          523.0
          438.0
          700C
          int
          110
           
           
          77
          618.0
           
          L
          538.5
          469.6
          700C
          int
          125
           
           
          78
          656.0
                     
          +
          dr \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html new file mode 100644 index 0000000..4f6e320 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html @@ -0,0 +1,32 @@ + + +Slowtwitch.com: Latest News & Reader Coupons + + + +
          +<%ticker_loop%> + + + + + +<%loop coupon_links_loop%> + + + +<%endloop%> +
          + + Latest News & Reader Coupons + +
          + <%coupon%> +
          +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html.bak2 new file mode 100644 index 0000000..7790502 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_ticker_coupons.html.bak2 @@ -0,0 +1,3 @@ +<%loop coupon_links_loop%> + <%coupon%> +<%endloop%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_video_player.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_video_player.html new file mode 100644 index 0000000..07d6232 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/include_video_player.html @@ -0,0 +1,25 @@ +<% if not image %> +<% Plugins::ConvertVideo::get_file_path($ID, "image_file_field") %> +<% set image = $image_file_field_path %> +<% endif %> +<% if not video %> +<% Plugins::ConvertVideo::get_file_path($ID, "flash_file_field") %> +<% set video = $flash_file_field_path %> +<% endif %> +<% Plugins::ConvertVideo::get_flash_dimension() %> +
          + +
          + +
          \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html new file mode 100644 index 0000000..45f4b63 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html @@ -0,0 +1,47 @@ +<% set url = $config.db_cgi_url %> +<% set show_thumbnail = '' %> +<%if Link_Type eq 'photo' and Image1_thumbnail %> +<% set show_thumbnail = "$url/jump.cgi?ID=$ID&v=Image1_thumbnail" %> +<%elseif Link_Type eq 'video' and Thumbnail_Path %> +<% set show_thumbnail = "$url/jump.cgi?ID=$ID&v=Thumbnail_Path" %> +<%elseif Link_Type eq 'video' and Thumbnail_URL and Thumbnail_URL ne 'http://' %> +<% set show_thumbnail = $Thumbnail_URL %> +<%endif%> +<%rewrite_detail_url%>
          + <% if show_thumbnail %> +
          + +
          +
          + <%endif%> + +

          + <%if detailed_url and isValidated eq 'Yes'%><%elsif URL ne 'http://' and isValidated eq 'Yes'%><%endif%><%if highlight%><%Links::Tools::highlight($Title, $query)%><%else%><%Title%><%endif%><%if isValidated eq 'Yes'%><%if detailed_url or URL ne 'http://'%><%endif%><%endif%> + <%if search_results_categories.$ID %>(<% search_results_categories.$ID %>)<%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> + <%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> + <%~endif%> +

          + <%if URL ne 'http://'%>

          <%if isValidated eq 'Yes'%><%endif%><%if highlight%><%set equery = escape_html $query%><%set eURL = escape_html $URL%><%Links::Tools::highlight($eURL, $equery)%><%else%><%escape_html URL%><%endif%><%if isValidated eq 'Yes'%><%endif%>

          <%endif%> + +

          + <%~if Votes%> + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" title="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) + <%~endif%> + <%~if paymentsEnabled and ExpiryDateFormatted and wasPaid%> + <%if isNotify or isExpired%><%endif%><%if isExpired%>Expired on:<%else%>Expiry date:<%endif%> <%ExpiryDateFormatted%><%if isNotify or isExpired%><%endif%> + <%~endif%> +

          + + <%if Description%><% set desc = shorten_it($Description,200) %>
          <%if highlight%><%Links::Tools::highlight($desc, $query)%><%else%><%desc%><%endif%>
          <%endif%> + + <%if show_thumbnail%> +
          + <%endif%> +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html.bak2 new file mode 100644 index 0000000..c8b3678 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link.html.bak2 @@ -0,0 +1,39 @@ +<%rewrite_detail_url%>
          +

          + <%if detailed_url and isValidated eq 'Yes'%><%elsif URL ne 'http://' and isValidated eq 'Yes'%><%endif%><%if highlight%><%Links::Tools::highlight($Title, $query)%><%else%><%Title%><%endif%><%if isValidated eq 'Yes'%><%if detailed_url or URL ne 'http://'%><%endif%><%endif%> + <%if isNew%>new<%endif%> + <%if isChanged%>updated<%endif%> + <%if isPopular%>popular<%endif%> + <%~if paymentsEnabled%> + <%if isUnpaid%>unpaid<%endif%> + <%if isExpired%>expired<%endif%> + <%if isFree%>free<%endif%> + <%~endif%> +

          + <%if URL ne 'http://'%>

          <%if isValidated eq 'Yes'%><%endif%><%if highlight%><%set equery = escape_html $query%><%set eURL = escape_html $URL%><%Links::Tools::highlight($eURL, $equery)%><%else%><%escape_html URL%><%endif%><%if isValidated eq 'Yes'%><%endif%>

          <%endif%> + +

          + <%~if Votes%> + <%~set intRating = $Rating i/ 1%> + " alt="<%intRating%> out of 10 stars" title="<%intRating%> out of 10 stars" /> (<%Votes%> vote<%if Votes != 1%>s<%endif%>) + <%~endif%> + <%~if paymentsEnabled and ExpiryDateFormatted and wasPaid%> + <%if isNotify or isExpired%><%endif%><%if isExpired%>Expired on:<%else%>Expiry date:<%endif%> <%ExpiryDateFormatted%><%if isNotify or isExpired%><%endif%> + <%~endif%> +

          + + <%if Description%>
          <%if highlight%><%Links::Tools::highlight($Description, $query)%><%else%><%Description%><%endif%>
          <%endif%> + +

          + <%~if isValidated eq Yes%> + <%--if Review_Count%>Read <%Review_Count%> Comment<%if Review_Count != 1%>s<%endif%><%endif%> + Comment on this article--%> + <%--a href="<%config.db_cgi_url%>/rate.cgi?ID=<%ID%>">Rate It + <%if config.bookmark_enabled%>Bookmark It<%endif%> + <%if not isExpired and not isUnpaid%> + <%if isLinkOwner or not config.user_required%>Edit this link<%endif%> + <%endif%> + <%~endif%> + <%if paymentsEnabled%><%if not wasPaid%>New Payment<%else%>Renewal Payment<%endif%><%endif%> +

          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link_added.eml new file mode 100644 index 0000000..9a6de95 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/link_added.eml @@ -0,0 +1,34 @@ +To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +Subject: Your link has been approved +From: <%config.db_admin_email%> + +Hello<%if Contact_Name%> <%Contact_Name%><%elsif Name%> <%Name%><%endif%>, + +Thank you for visiting our site. We've added the following link into +our directory: + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact E-mail: <%Contact_Email%> + +You can see your new listing at: + + <%config.build_root_url%>/<%home_index%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : link_added.eml + Description : This is the e-mail a user receives when their link is + validated. + Tags : All the properties of the link that was just validated + are available plus: + Category => The category the link was added to. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login.html new file mode 100644 index 0000000..a76ac31 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login.html @@ -0,0 +1,81 @@ + +<%~if logout and error%> + <%~set message = $error%> + <%~set error = ''%> +<%~endif%> +<%~if url and not error%> + <%~set error = 'You must first login before you can access that.'%> +<%~endif%> + + + <%site_title%>: User Login +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          User Login

          + +

          Login:<%--site_title--%>

          + +
          + + <%if url%><%endif%> + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +<%~if config.user_sessions eq Cookies%> +
          + +
          + +
          +
          +<%~endif%> +
          + +
          +
          + +

          + <%--If you don't have an account, please register.
          + If you've forgotten your password, we can e-mail it to you. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_email.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_email.html new file mode 100644 index 0000000..891fe6f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_email.html @@ -0,0 +1,61 @@ + + + + <%site_title%>: Forgotten Password +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Forgot your password?

          + +

          + Simply enter your e-mail address that you signed up with and we will e-mail you your password. +

          + +
          + + <%if url%><%endif%> + +
          + +
          + +
          +
          +
          + +
          +
          + +<%--p> + If you don't have an account, please register. + + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_success.html new file mode 100644 index 0000000..172d5bf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/login_success.html @@ -0,0 +1,48 @@ + + + + <%site_title%>: Logged In +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Logged In

          + +

          + You have been successfully logged in.<%--site_title--%> +

          + +<%if not d and Links::Utils::is_editor%> +

          + Enter the editor system. +

          +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify.html new file mode 100644 index 0000000..72247b9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify.html @@ -0,0 +1,99 @@ + + + + <%site_title%>: Modify a Link + + + +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Modify a Link

          +<%~ set megabytes = 1048576 ~%> +<%~ set image_cfg = Links::Plugins::get_plugin_user_cfg('SlideShow') ~%> +<%~ set image_size = image_cfg.max_upload_size / $megabytes ~%> +<%~ set image_size = round($image_size) ~%> +<%~ set video_max_size = Plugins::ConvertVideo::get_video_max_size() ~%> +<%~ set video_size = $video_max_size / $megabytes ~%> +<%~ set video_size = round($video_size) ~%> +

          + Note: image files must be smaller than <% if image_size %><% image_size %><%else%>1<%endif%>MB and video files must be smaller than <% if video_size %><% video_size %><%else%>1<%endif%>MB. +

          + +
          + +<%~if LinkID%> + + +<%~else%> + <%~if config.db_gen_category_list == 2%> + + + + <%~endif%> +

          + Enter the new information (all of it, not just the changes) below: +

          +<%~endif%> +<%include include_form.html%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_select.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_select.html new file mode 100644 index 0000000..e57ada3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_select.html @@ -0,0 +1,55 @@ +<%~ set title = "Modify a Link" %> + + + + <%site_title%>: <%title%> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          <% title %>

          + +

          + Please select which link you would like to modify: +

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +
          +<%~loop link_results_loop%> + disabled="disabled"<%endif%> /> +<%include link.html%> +<%~endloop%> + +
          + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_success.html new file mode 100644 index 0000000..082a64d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/modify_success.html @@ -0,0 +1,79 @@ + + + + <%site_title%>: Link Modified +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Link Modified

          + +

          +<%~if payment_term eq free%> + Your link has been changed to a free link: +<%~else%> + We have received your request to modify the link as follows: +<%~endif%> +

          + +
          + +
          <%Title%>
          +
          +
          + +
          + <%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          + <%~else%> + <%Category%> + <%~endif%> +
          +
          +
          + +
          <%if Link_Type eq 'photo'%>Photo Gallery<%elseif Link_Type eq 'video'%>Video<%else%>Article<%endif%>
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +<%if not config.user_direct_mod and payment_term ne free%>

          Thank you! We will send you an e-mail once your link has been validated.

          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html new file mode 100644 index 0000000..45deee2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html @@ -0,0 +1,9 @@ +
          + +<%Plugins::MostPopular::generate_popular_links%><%--FromDate%> to <%ToDate--%> +<%set i = 1%> +

          <%loop MostPopularLinks%><%rewrite_detail_url%> +<%i%>. <%Title%> <%--(<%count%> views)--%>

          <%set i = i+1%> +<%endloop%>

          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html.bak2 new file mode 100644 index 0000000..c19373e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/most_popular.html.bak2 @@ -0,0 +1,9 @@ +
          + +<%Plugins::MostPopular::generate_popular_links%><%--FromDate%> to <%ToDate--%> +<%set i = 1%> +

          <%loop MostPopularLinks%><%rewrite_detail_url%> +<%i%>. <%Title%> <%--(<%count%> views)--%>

          <%set i = i+1%> +<%endloop%>

          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/new.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/new.html new file mode 100644 index 0000000..c578179 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/new.html @@ -0,0 +1,68 @@ + + + + <%site_title%>: New Links +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          New Links

          + +<%-- Displays a list of dates and counts for each link --~%> +<%if new_index~%> +
            +<%~loop link_results_loop%> +
          • <%date%> (<%count%>)
          • +<%endloop~%> +
          +<%~-- Displays the new links without span pages --~%> +<%~elsif title_linked_loop%> +<%~loop title_linked_loop%> + <%new_date%> + <%loop links%> +

          <%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>

          +<%include link.html%> + <%~endloop%> +<%~endloop%> +<%~-- Displays the actual new links --~%> +<%else%> +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%if link_results_loop%> +<%loop link_results_loop%> +<%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +<%include link.html%> +<%endloop%> +<%endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html new file mode 100644 index 0000000..2fdaf4e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html @@ -0,0 +1,11 @@ +
          + +<%Plugins::NewestReviews::generate_newest_reviews%> +<%set i = 1%> +

          <%loop NewestReviewsLinks%><%rewrite_detail_url%> +<%i%>. <%Review_Subject%> +

          <%set i = i+1%> +<%endloop%> +

          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html.bak2 b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html.bak2 new file mode 100644 index 0000000..54982be --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/newest_reviews.html.bak2 @@ -0,0 +1,11 @@ +
          + +<%Plugins::NewestReviews::generate_newest_reviews%> +<%set i = 1%> +

          <%loop NewestReviewsLinks%><%rewrite_detail_url%> +<%i%>. <%Review_Subject%> +

          <%set i = i+1%> +<%endloop%> +

          +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/privacy.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/privacy.html new file mode 100644 index 0000000..671a8cd --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/privacy.html @@ -0,0 +1,84 @@ + + + + <%site_title%>: Privacy Policy +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Privacy Policy

          + +

          + Written by: Dan Empfield
          + Date: Tue Sep 18 2007
          +

          + +
          +
          +INFORMATION WE GATHER +

          +
          The information we gather falls into two categories: 1) personal information you voluntarily supply when you complete a survey, register as a user on our FORUM, enter a contest or provide your e-mail address, and 2) tracking information collected as you navigate through our sites. +

          +
          PERSONAL INFORMATION VOLUNTARILY SUPPLIED: +

          +
          If you have registered or signed up on Slowtwitch, we will not sell, rent, swap or authorize any third party to use your email address without your permission. This also applies to any information that personally identifies you, except as noted immediately below. +

          +
          We may disclose personal information if we are required to do so by law or we in good faith believe that such action is necessary to (1) comply with the law or with legal process; (2) protect and defend our rights and property; (3) protect against misuse or unauthorized use of our website(s); or (4) protect the personal safety or property of our users or the public (among other things, this means that if you provide false information or attempt to pose as someone else, information about you may be disclosed as part of any investigation into your actions). +

          +
          We do, however, share information about our audience in aggregate form. For example, we may want to know how long the average reader spends on our site, or which pages or features get the most attention. Slowtwitch may perform statistical analyses of readers and their reading patterns for product development purposes and to generally inform advertisers about the nature of our subscriber base. We may use demographic and preference information to allow advertising on our Web sites to be targeted, in aggregate, to the users for whom they are most pertinent. +

          +
          USE OF COOKIES: +

          +
          This Site uses Google Analytics, a web analytics service provided by Google, Inc. (�Google�). Google Analytics uses �cookies�, which are text files placed on your computer, to help us analyze how users use the Site. The information generated by the cookie about your use of the Site (including your IP address) will be transmitted to and stored by Google on their servers. Google will use this information for the purpose of evaluating your use of the Site, compiling reports on Site activity for us, and providing other services related to Site activity and Internet usage. Google may also transfer this information to third parties when required to do so by law, or where third parties process the information for Google. +

          +
          This site also collects information for both Facebook and Google Remarketing, which enables third party vendors who participate in Facebook�s Custom Audience program as well as the Google Display Network (inclusive of Google) to show targeted ads on the Internet. Third party vendors, including Facebook and Google, use cookies to serve ads based on a user�s prior visits to this website. +

          +
          You may refuse the use of cookies by selecting the appropriate settings on your browser. Alternatively, you may opt out of Google�s use of cookies by visiting the Google advertising opt-out page. To opt-out of Facebook�s use of cookies, visit Facebook�s advertising opt-out page. The information generated by the cookie may also be aggregated and accessed by third parties who provide services related to the Site to us. By using this Site, you consent to the processing of such data about you by Google, Facebook and such third parties in the manner and for the purposes set forth above. +

          +
          INTERNET BASED ADVERTISING: +

          +
          Some of the ads you see on this web site are tailored to your interests and based on your activity online or in the applications on your mobile device. This type of ad tailoring — sometimes called "interest-based" or "online behavioral" advertising — is enabled through various technologies, including browser cookies, mobile advertising identifiers as well as other non-cookie technologies. To help protect your privacy, we are committed to providing you transparency and choice for these activities. For more information and to opt-out of interest-based advertising, please visit: http://optout.networkadvertising.org/?c=1#!/ +

          +
          FORUM USE +

          +
          Any information you disclose when posting to our FORUM, along with your message board screen name or ID, becomes public, and Slowtwitch has no control over how readers may use or treat what you post or divulge. +

          +
          EMAIL CORRESPONDENCE +

          +
          If, at any time, you prefer not to receive email newsletters or correspondence from us, simply follow the unsubscribe options at the bottom of each e-mail. +

          +
          AMENDMENTS TO THIS POLICY +

          +
          Our Privacy Policy may be amended from time to time. Any such changes will be posted on this Privacy Policy page. +
          + +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/retail_survey_0613.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/retail_survey_0613.html new file mode 100644 index 0000000..bd2d82a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/retail_survey_0613.html @@ -0,0 +1,122 @@ + + + +<%site_title%>: Survey of Bike and Tri Retailers, June, 2013 +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Survey of Retailers: June 2013

          +

          Authored by Dan Empfield

          + +Below are selected results of our mid-June survey taken of specialty bike retail stores. We asked 700 specialty stores to participate, 164 stores responded and took this survey. Below are results I felt most applicable and timely. There are a LOT of charts below, so, the read is a little weighty. I hope you'll find it helpful in your business.

          + +I think it’s fairest to begin by discussing who took this survey. Of the 700 stores I asked to participate a large number of them are, no doubt, tri-leaning, because the very stores I invited to participate meet at least one of the following criteria. They are: 1) the larger overall higher-end stores in the United States and Canada; 2) those stores heavily invested in high-end sales; 3) stores heavily invested in bike fit. In order just to be circumscribed inside the Slowtwitch universe there is probably some degree of tri-interest if not specificity. To wit: + +

          + +

          This first chart, immediately above, is the way the 164 respondents answered, when asked what triathlon represents in importance, as a market (a vertical) in their stores. So, as you see, tri is an important market to the respondents. But then, this survey is a snapshot of how tri and higher-end road are selling this season in retail stores. + +In the chart below we see how these stores are doing, store-wide, all markets, all verticals:

          + +

          + +

          Let’s see how tri bike sales doing in these stores, and just below that how road bike sales are doing in these stores, for comparison:

          + +

          + +

          + +

          + +

          In the stores we surveyed, both tri and road sales are up more than they’re down, however, let’s filter out those respondents who say they don’t sell a particular type of product (in other words, let us only count stores that sell road when we calculate whether they're up or down YTD in road sales). When we do so, tri sales are up in 37 percent of the stores who sell this product. They’re down in 35 percent of the stores who sell the product. So, really, tri sales are flat, year-over-year, in North America so far season-to-date. I think that’s what we can say based on this survey. + +Road sales are, in general, up in 45 percent of the stores surveyed, so, road as a market is doing slightly better than tri alone. MTB is about even with road, that is, if you consider only those stores that sell MTB (119 of the 164 respondents), about 45 percent report that MTB sales are up. + +What about other triathlon-related products?

          + +

          + +

          Accessories, tri-related, seem to be doing okay. A little bit better than bike sales. About 40 percent of those who sell accessories report that their sales are up YTD, while about 23 percent report that sales are down. But we’re counting wetsuits separately, and here’s how wetsuits fared: + +

          + +

          Here’s where the market struggles. Slightly more report more down than up, and my guess is that this can be laid at the feet of three causes: the ability to easily buy a wetsuit mail order; the explosion of wetsuit brands without a corresponding, scaled, explosion in wetsuit sales; and the preponderance of race directors acting as conduits enabling the sale of XTERRA Wetsuits, that is, race registration engines, triathlon’s national governing body (USA Triathlon), and race directors all pushing the XTERRA brand directly to the consumer.

          + +I am not making a judgment or statement about this sales channel, rather just the observation that this seems to best explain why tri accessories (saddles, hydration systems, aero helmets, aero wheels, etc.) are up, but wetsuits sales are not. + +Still, for all this, wetsuit sales remain strong in many retail stores, that is, they are either flat or up in 6 out of 10 stores surveyed who carry this product, assuming same sales year-over-year mean same strong sales versus year-over-year weak sales. + +

          I’d like to change themes for a moment, and talk about fitting. Here’s how our 164 stores characterized bike fitting: + +

          + +

          Notable here, I think, is that almost 6 out of 10 stores say that fitting is a major part of their businesses, and that the number of those indicating it’s a small part of their business, and those who have no fit philosophy, are pretty small. Again, that might just be the nature of the respondents. Maybe those stores for whom fit is not on the radar are also not on my radar, so, very few of these stores took this survey, or were never asked to take it, and that's why stores of this nature are underreported here (if they are underreported).

          + +Of those who took the survey 43 percent say F.I.S.T. Is their go-to fit philosophy, and I’m surprised Retul is not more highly chosen. Maybe it’s just a case of who chose to respond to the survey. However, I think it’s more than that. I think Retul is well respected as a first class maker of fit tools, but I think its protocol is less well acknowledged. I don’t think that’s bad. Retul began as a protocol-agnostic maker of tools, and subsequently acquired and taught its own protocol. + +Conversely, F.I.S.T. is tool-agnostic, that is, F.I.S.T. works best with a fit bike (no newsflash there) and it works best-yet with specific X/Y adjustable fit bikes, however F.I.S.T. cares not whether that fit bike is a Guru Experience, a Purely Custom, an Exit Cycling or, indeed, a Retul Müve. Therefore, perhaps a lot of Retul Müve and Retul motion capture customers prefer these are their tools of choice, yet prefer as their F.I.S.T. protocol of choice. There may be some evidence of this inside the numbers of this survey. Here is how the above question is answered among those who have one of these 4 fit bikes: + +

          + +

          Staying on this theme, I think what’s notable in this survey is what happens once a shop does adopt the use of what I consider the leading “conforming” fit bikes: the 4 fit bikes that I think best facilitate the leading dynamic fit protocols. So, let’s look at how these 164 shops answered the questions above when we filter for these 4 fit simulators: + +

          + +
          + +

          If you do have one of these four fit bikes on your floor, your YTD tri bike sales are up 43 percent, rather than the overall average of 33 percent. If you have no fit bike at all in your store, you see the results, as reported by the stores themselves. One conclusion that one might draw is that tri customers are preferring to shop at stores that do have significant fit expertise. + +

          That established, shops that had no fit bike did not overly suffer. Their numbers, storewide, YTD, were only slightly worse than the results of all shops. Further, they’re MTB sales were even better. I think this is partly due to a lack, as of today, of much attention paid to MTB fit. + +

          If you ascribe to a fit system that does not employ the use of a fit bike, you don’t need a fit bike. I think the preponderant system in this category today is BG Fit, and I thought it illustrative to select those who employ BG Fit as their methodology of choice. Here is what happens to bike sales when BG Fit is the protocol: + +

          + +

          + +

          + +

          +

          + +

          In the three charts just above, we see what bike sales look like in those stores that have indicated they rely on the BG Fit system. If you only look at tri bike sales when BG Fit is the system employed (the first of the three charts just above) it's not a pretty sight. However, just below that chart is how these stores fare in the road vertical. Just below that - the chart immediately above - is what we see when BG Fit is the system employed and it’s MTB we’re considering. Things look much better in road and MTB sales. Just below, here’s what BG Fit users report as to their overall shop performance YTD, year-over-year: + +

          + +

          What’s our take-away? I think it’s that if you’re a Specialized retailer, BG Fit seems to be a suitable system for road bike sales and for MTB sales. Where things begin to get tougher is when BG Fit is the system used for tri bike fit. Partly, it’s because Specialized offers a variety of robust options for road and for MTB. The bikes are just so good, and the options sufficiently varied (a Roubaix fits riders that a Tarmac won’t fit and vice versa, and the Ruby is a terrific women's bike), that customers and fitters have options. BG Fit is designed to make Specialized bikes fit customers — to pair a customer with the right Specialized model. The Shiv is, in a way, analogous to the Roubaix, in that it’s “tall and narrow” in its geometry. There is no “Tarmac analog” made by Specialized. Therefore, if the fit system is geared only to show how to fit a Shiv to a customer, that’s going to be a problem for those customers who need to ride the morphological analog to a Tarmac.

          + +To recap, and in conclusion, the tri market as a whole seems to me to be slightly up, but the trajectory is not steep, rather it's like riding up a 1 percent grade. I think those who do well in tri are those who have a specific interest in fitting. I suspect it’s because triathletes both need more attention given to fit, and they know it. And because they know it, it’s a self-fulfilling cycle: because they need a shop with fit expertise they seek out shops with advanced knowledge and advanced tools. Those shops get the sales. + +I think the same thing is happening in high end road. F.I.S.T. has both a road and a tri protocol, so does Retul, the Guru Experience project uses the F.I.S.T. protocol for both tri and road fitting, and increasingly the discriminating customers are migrating toward the use of one of these dynamic protocols with the use of a fit bike that supercharges these protocols. + +

          I have some other thoughts about the tri market, but they are suspicions and guesses and not a result of the survey answers. So I’ll leave this for a future survey and analysis. Any retailers who have questions or comments about this survey can either email me, or we have a Fitter's Forum on Slowtwitch and while this survey isn't specific just to fitting some of us hang out there, and you may ask questions or make comments there as well. + +<%include include_content_bottom.html%> +

          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/review_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/review_include.html new file mode 100644 index 0000000..8ef9e8c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/review_include.html @@ -0,0 +1,43 @@ +
          +<%~if show_link_info%> + <%~set ID = $LinkID%> + <%~Links::Utils::load_link_info%> +<%include link.html%> + <%~set ID = ''%> +<%~endif%> +

          + <%Review_Subject%><%if Review_CanModify%> (edit)<%endif%> + " alt="<%Review_Rating%> out of 5 stars" title="<%Review_Rating%> out of 5 stars" /> + <%if Review_IsNew%>new<%endif%> +

          +<%~if Review_ByLine%> +
          + <%Review_ByLine%> +
          +<%~endif%> +

          + Reviewed by: <%if Review_GuestName%><%Review_GuestName%><%else%><%Review_Owner%><%endif%>, <%Review_Date%><%if Review_ModifyDate%> (Modified: <%Review_ModifyDate%>)<%endif%> +

          +<%~if Review_Contents%> +
          + <%Review_Contents%> +
          +<%~endif%> + <%--div class="reviewhelpful clear"> + <%if Num%><%Review_WasHelpful%> of <%Num%> people found this review helpful<%endif%> +
          + <%if nh and nh != 1%><%endif%> + + <%if ID%><%endif%> + <%if username%><%endif%> + <%if ReviewID%><%endif%> + + <%~if last_helpful%> + Thanks for the feedback. + <%~else%> + Was this review helpful to you? + <%~endif%> + +
          + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/runstore_survey_0717.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/runstore_survey_0717.html new file mode 100644 index 0000000..17dc954 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/runstore_survey_0717.html @@ -0,0 +1,81 @@ + + + +<%site_title%>: Survey of Tech Run Retailers, July, 2013 +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Survey of Tech Running Retailers: July 2013

          +

          Authored by Dan Empfield

          + +Many of you, as of this writing, are getting ready to head to Outdoor Retailer. To that end, here are the results of our state-of-the-industry sampler poll. We just conducted a fairly decent-sized poll of bike retailers, about 170 shops participated. We don’t have the same deep relationships with footwear retailers that we have with bike shops, however, we did poll 36 retail stores and below is what we found. +

          +First, some disclaimers. As there are probably 700 tech running footwear retailers in the U.S., for us to poll only 36 of them means you can leverage these results only so far. Also, we publish Slowtwitch.com, and it’s a portal read by triathletes. It's only natural to assume that the poll respondents were stores trending toward triathlon-centricity. +

          +Maybe that’s true. We asked this in our poll, and we’ll lead with a chart telling us who the respondents were. +

          +

          +

          +

          Each store was asked to rank 11 footwear brands by revenues. A store would place a 1 by its largest revenue brand, 2 for second-largest, and on down, with an option to indicate that the brand is not sold. The chart below tells you more about who are respondents are. +

          +Brooks is the largest revenue brand in these 36 stores when considered in the aggregate. Asics and Saucony are close behind in revenues. This probably sounds about right. However, look how far down we see Nike, and Adidas even further down. Obviously this is not representative of these companies, which taken together probably total near $40 billion in annual sales. However, none of the 36 stores we polled were mass marketers, or sporting goods stores, or Foot Lockers. None sell basketball or soccer shoes. All 36 polled were independent running footwear sellers. Independent running footwear resellers and running footwear manufacturers can look at this chart and determine better than I whether this chart rings true as a proxy for these kinds of businesses in general. +

          +

          +

          +

          While others are better equipped than I to critique the above chart for relevance, I find this chart matches quite closely the trends we see among our readers. If you consider polls taken of Slowtwitchers over the past 6 years, shown below, Asics has fallen in brand use, Saucony has grown, so has Brooks, and if you look at our most recent polls, our readers are telling us that they’re buying what the retailers are telling us they’re selling. +

          +

          +

          We can see from the poll above the trajectory of each brand by looking at the circuitous lines each brand is scribing, each time we ask the question of our readers. Asics has gone in one direction, Brooks and Saucony in the other. Is this also what we see when we ask the retailers we polled this same question? (Neither the retailers, nor anyone, has seen our aggregate polling of Slowtwitchers prior to its publication above.) +

          +

          +

          +

          In the poll just above, this is how our 36 running retailers answered the question. We simply asked these retailers whether a running shoe brand was ascendant in their stores, or whether it was in decline. The obvious ascendant large brands were Brooks and Saucony. In the smaller brands, the clear ascendant upstart is Hoka One One. +

          +We also wanted to know what trends these retailers sensed in the engineering or architecture or technical style of running shoes. We didn’t present them an exhaustive list, we just asked two questions: Is the minimalist shoe in ascendancy or decline? Second, is the lower-drop, or low-ramp, shoe trending up or down? Some folks may think this is confusing, because minimalist shoes have as one feature low-drop. However, our retailers had no trouble parsing between the two terms. +

          +

          +

          +

          Finally, I wanted to know what activities these retailers themselves personally engage in. Maybe this is not relevant, however, I suspect it is, because in my own 25 years in this business I’ve noticed that a lot of buying and selling is personal. When a brand honors or conversely dishonors a particular market (whether high school runners, walkers, triathletes, ultra or trail runners, newbies, oldsters, women, the frugal, the spendy) through its ads, its sponsorships, its price points, the engineering and models of its shoes, or simply through the words and attitudes of its employees and sales reps, I think that has an effect on how that brand is treated and positioned in the store. That effect can either be positive or negative. +

          +

          +

          +

          True, we only have answers from 36 stores, but I think it’s notable, surprising to some, but not to me, that so many shop principals do personally engage in both footraces and multisports races. Even those who indicated that triathlon is neither their largest or even a vital market (more than half) are nevertheless personally engaged in multisport on a competitive level. Therefore, I think brands adopt a dismissive attitude of any market at their own peril, even if they are not as a business engaged in that market. +

          +I think Asics has turned a corner in its approach to and interest in multisport, probably helped through the Hyperspeed winning the men’s Hawaiian Ironman World Championship twice over the past 3 years. Asics is closing in on $1 billion in annual sales, but while Nike has a stronghold in basketball, Adidas’ is in soccer, Asics has always hung its hat on running. Running has always been its core. I think Asics correctly sees this and is eager to reverse some of the trend lines above. +

          +My takeaway, just looking at all the charts above, is that Born to Run’s impact on running technology – specifically minimalism – is waning. But it opened the door – it forced open the door – to new ideas of how to build running shoes, and in so doing made a way for existing second-tier brands (like Saucony) to move into the top tier, while allowing new brands (like Newton and Hoka) to get a leg up. +

          +“Hold on!” you might complain, “These specialty stores, even all 700 of them, still only represent well less than half of the sales of tech running shoes in the U.S.” True. However, I’ve never known Foot Locker, Zappos, or Sports Authority to take a flier on an unknown, unproven product. They all only order deep in shoes that these 700 stores first made popular. In a way, these tech running stores hand permission slips to running footwear brands. Until these specialty stores – through their front-line efforts in each community – green light the sale of these models to the mass merchants, these new models aren’t getting sold in any significant numbers. +

          +For this reason I pay attention to what these small, independent tech running stores say, because they’re the industry’s bellweather. I hope you found this small survey illustrative. + + +<%include include_content_bottom.html%> +

          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/saddle_tour_13.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/saddle_tour_13.html new file mode 100644 index 0000000..4ca18b9 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/saddle_tour_13.html @@ -0,0 +1,389 @@ + + + +<%site_title%>: Slowtwitch Saddle Tour +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Slowtwitch Saddle Tour

          +

          22 Cities, 39 Partner Locations

          +

          + + +An overview of the Slowtwitch Saddle Tour is published elsewhere. What you'll read here are the mechanics of how a saddle "demo" operates, how you go about obtaining a demo for yourself, and how you as a Saddle Tour participant can reap the greatest benefit from this initiative. +

          +To forestall the inevitable question of "Why isn't my LBS a part of this Tour?", the participating retail stores were chosen in this way: They already had in their stores the necessary (and expensive) tooling to execute the saddle demo protocols; their personnel had sufficient and appropriate training; and they each agreed to carry the necessary saddle inventories. It's that simple. These stores did not pay us to participate. We approached each of these stores on the basis of what we knew about them. We asked 40 stores to participate, and 39 said yes. +

          +Scheduling a Saddle Tour Appointment
          +Most Saddle Tour stops are 3 or 4 days in length, that is, it's like when a touring act, or a play, comes to your town for 4 shows. Once those shows are over, they're over. So, the wise and enterprising concert goer plans in advance. You may be able to take a Saddle Tour demo on a walk-in basis. However, most participating shops require an appointment, or some advance notice. On the list of participating shops below is the phone number of every shop. In some cases, the name of the person you should ask for is also listed. Call before you arrive. Allow for a half-hour. Most Saddle Tour demos will take 15 or 20 minutes. Maybe 25. Still, best allow for 30. +

          +There is no charge to you for the saddle demo, however there is certainly a limit to how many saddle demos can be executed during the Slowtwitch Saddle Tour window. These demos occur aboard fit bikes, which have as their "day jobs" the task of sitting underneath those who need to be fitted for road or tri bikes. Therefore, because this is a no-charge service does not mean it's an especially available service. If you wait to schedule an appointment you may get your feelings hurt when you discover no appointment slots exist. +

          +What you should bring
          +Bring cycling shoes, pedals, and your kit, i.e., your bib or shorts and jersey. And socks. Bring your fit coordinates if you want to get the most out of this session, and by "most" I'm talking about a saddle demo while in your aero position. This demo is going to take place on a fit simulator, and you want that simulator set up to match the position in which you'll ride your tri bike. So, what's a fit coordinate? Go to your Slowtwitch Forum User Profile, look at the bottom of that profile, you'll see a utility called Bike Fit Manager. This is the place you archive your bike fit coordinates. This will tell you how to measure your coordinates. If you want to know what this looks like, here's my User Profile, and you can see what my fit coordinates look like. If you bring these fit coordinates in to your Slowtwitch Saddle Tour demo, these participating shops are trained in how to match the fit bike to your coordinates. +

          +You should also bring with you as much as you know about your existing set up: the saddle you're now riding, the aerobars you ride, and so forth. +

          +Is this a bike fit session?
          +No. You're not getting a bike fit. At least not a proper bike fit. If you do not know your coordinates, or if you don't want to bring coordinates because you are certain your bike is not set up even close to properly, the Slowtwitch Saddle Tour participating shop will spend 3 or 4 minutes roughing out a position for you. Getting you close. +

          +One thing I hope you'll take away from this exercise is a sense of how these new, modern fit bikes work. It is on these tools that fitters execute today's modern dynamic fits. Consider coming back to this shop to avail yourself of a proper fit session. +

          +You may also want to tell the fitter who's executing the Saddle Tour demo what your target race power is, if you know it. The more you can replicate race conditions, the more this demo will bear fruit. +

          + +

          • • • • • • List of Metro Areas in Date Order • • • • • •

          +

          +Atlanta, GA • Aug 15 - 17 • Thur thru Sat
          +Boston, MA • Aug 15 - 17 • Thur thru Sat
          +Denver, CO • Aug 15 - 17 • Thur thru Sat
          +Boulder, CO • Aug 15 - 17 • Thur thru Sat
          +Washington DC • Aug 21 - 24 • Wed thru Sat
          +Baltimore, MD • Aug 21 - 24 • Wed thru Sat
          +Los Angeles, CA • Aug 21 - 24 • Wed thru Sat
          +Dallas/Ft. Worth, TX • Aug 21 - 24 • Wed thru Sat
          +Detroit, MI • Aug 21 - 24 • Wed thru Sat
          +Tampa, FL • Aug 21 - 24 • Wed thru Sat
          +Orlando, FL • Aug 21 - 24 • Wed thru Sat
          +San Francisco, CA • Aug 23 - 24 • Fri thru Sat
          +Raleigh, NC • Aug 28 - 31 • Wed thru Sat
          +State of Connecticut • Aug 28 - 31 • Wed thru Sat
          +Minneapolis, MN • Aug 28 - 31 • Wed thru Sat
          +San Diego, CA • Aug 28 - 31 • Wed thru Sat
          +Houston, TX • Aug 28 - 31 • Wed thru Sat
          +Seattle, WA • Aug 28 - 31 • Wed thru Sat
          +Sacramento, CA • Aug 28 - 31 • Wed thru Sat
          +New York, NY • Sep 11 - 14 • Wed thru Sat
          +Philadelphia, PA • Sep 25 - 28 • Wed thru Sat
          +Chicago, IL • Sep 25 - 28 • Wed thru Sat
          + +

          • • • • • • List of Participating Shops • • • • • •

          +

          +Atlanta, GA • Aug 15 - 17 • Thur thru Sat

          + +All3Sports
          +Brent Pease
          +8601 Dunwoody Pl #420
          +Atlanta, GA
          +770-587-9994
          + +• • • • • •

          + +Boston, MA • Aug 15 - 17 • Thur thru Sat

          + +Fast Splits
          +Brian Hughes
          +612 Washington St
          +Newton, MA 02458
          +617-630-8500

          + +Fit Werkx
          +67 Foster St.
          +Peabody, MA 01960
          +978-532-7348

          + +• • • • • •

          + +Denver, CO • Aug 15 - 17 • Thur thru Sat

          + +Treads Bicycle Outfitters Aurora
          +16701 E Iliff Ave
          +Aurora, CO 80013
          +303-750-1671

          + +Treads Bicycle Outfitters Lakewood
          +3234 S Wadsworth Blvd
          +Lakewood, CO 80227

          + +Treads Bicycle Outfitters Parker
          +10831 S Crossroads Dr
          +Parker, CO 80134
          +303-690-2900

          + +• • • • • •

          + +Boulder, CO • Aug 15 - 17 • Thur thru Sat

          + +Colorado Multisport
          +2480 Canyon Blvd
          +Boulder, CO 80302
          +303-865-4604

          + +• • • • •

          + +Washington DC • Aug 21 - 24 • Wed thru Sat

          + +Sportfit Lab
          +Doug Baumgarten
          +1041 Sterling Rd #103
          +Herndon, VA 20170
          +703-435-5537

          + +• • • • •

          + +Baltimore, MD • Aug 21 - 24 • Wed thru Sat

          + +Bike Doctor
          +Steve Ruck
          +953 Ritchie Hwy
          +Arnold, MD 21012
          +410-544-3532

          + +• • • • •

          + +Los Angeles, CA • Aug 21 - 24 • Wed thru Sat

          + +Triathlon Lab
          +3328 Pico Blvd
          +Santa Monica, CA
          +310-581-6100

          + +Bike Religion
          +34150 E Pacific Coast Hwy
          +Dana Point, CA
          +855-433-8806

          + +Hypercat Racing
          +4160 Market St #3
          +Ventura, CA 93003
          +805-477-0353

          + +• • • •

          + +Dallas/Ft. Worth, TX • Aug 21 - 24 • Wed thru Sat

          + +Knobbies and Slicks
          +8300 Precinct Line Rd #110
          +Colleyville, TX
          +817-281-4957

          + +Tri Shop
          +6101 Windhaven Parkway #100
          +Plano, TX 75093
          +972-378-5476
          + +• • • • • •
          + +Detroit, MI • Aug 21 - 24 • Wed thru Sat

          + +Fraser Bicycle
          +34501 Utica Road
          +Fraser, MI 48026
          +586-294-4070
          + +• • • • • • •

          + +Tampa, FL • Aug 21 - 24 • Wed thru Sat

          + +Outspokin
          +3300 S. Dale Mabry Hwy
          +Tampa, FL
          +813-831-1414

          + +• • • • • •

          + +Orlando, FL • Aug 21 - 24 • Wed thru Sat

          + +Evolve Bicycles
          +13 Blake Blvd.
          +Celebration, FL 34747
          +321-939-2453

          + +Out-Spoke-N
          +1061 South Sun Drive #1073
          +Lake Mary, FL 32746
          +407-688-1959

          + +• • • • •

          + +San Francisco, CA • Aug 23 - 24 • Fri thru Sat

          + +Sports Basement Presidio
          +610-Old Mason St.
          +San Francisco, CA
          +415-437-0100

          + +Sports Basement Walnut Creek
          +1881 Ygnacio Valley Rd.
          +Walnut Creek, CA
          +925-941-6100

          + +Sports Basement Sunnyvale
          +1177 Kern Ave
          +Sunnyvale, CA
          +408-732-0300

          + +• • • • • •

          + +Raleigh, NC • Aug 28 - 31 • Wed thru Sat

          + +Inside Out Sports
          +8111 Creedmoor Rd
          +Raleigh, NC
          +Brennan Station
          +919-861-9903

          + +• • • • • •

          + +State of Connecticut • Aug 28 - 31 • Wed thru Sat

          + +Bethel Cycle
          +5 Depot Pl
          +Bethel, CT 06801
          +203-504-8960

          + +Greenwich Bicycles
          +35 Amogerone Crossway
          +Greenwich, CT 06830
          +203-869-4141

          + +Pacific Swim Bike Run
          +575 Pacific St.
          +Stamford, CT 06902
          +203-504-8960

          + +• • • • • •

          + +Minneapolis, MN • Aug 28 - 31 • Wed thru Sat

          + +Now Bikes & Fitness
          +1201 County Road East, #100
          +Arden Hills, MN 55112
          +651-490-7709

          + +Now Bikes & Fitness
          +75 N Snelling Ave
          +St. Paul, MN 55104
          +651-644-2354

          + +• • • • • •

          + +San Diego, CA • Aug 28 - 31 • Wed thru Sat

          + +Nytro Multisport
          +940 S. Coast Hwy 101
          +Encinitas, CA
          +760-632-0006

          + +Moment Cycle Sports
          +2816 Historic Decatur Rd #135
          +San Diego, CA 92106
          +619-523-2453
          + +• • • • • •

          + +Houston, TX • Aug 28 - 31 • Wed thru Sat

          + +Bicycle World
          +14536 Memorial Dr.
          +Houston, TX
          +281-556-0923

          + +Bicycle World
          +23233 Kingsland Blvd
          +Katy, TX 77494
          +281-665-1016

          + +• • • • • •

          + +Seattle, WA • Aug 28 - 31 • Wed thru Sat

          + +Northwest Tri and Bike
          +15423 SE 272nd St.,
          +Kent, WA 98042
          +253-638-2453

          + +• • • • • •

          + +Sacramento, CA • Aug 28 - 31 • Wed thru Sat

          + +Davis Wheelworks
          +Joe Santos
          +247 F St.,
          +Davis, CA 95616
          +530-753-3186

          + +Rocklin Endurance Sports
          +Rich Burns
          +22161 Sunset Blvd., #200
          +Rocklin, CA 95765
          +916-259-2820

          + +• • • • • •

          + +New York, NY • Sep 11 - 14 • Wed thru Sat

          + +ACME Bicycle Co.
          +Jonathan Blyer
          +597 Degraw Street, Suite 2F
          +Brooklyn, NY 11217
          +917-355-3397

          + +Cycle Craft
          +Brendan Poh
          +99 U.S. Hwy 46 East
          +Parsippany, NJ
          +973-227-4462

          + +• • • • • •

          + +Philadelphia, PA • Sep 25 - 28 • Wed thru Sat

          + +Bell's Bike Shop
          +Steve Palladinetti
          +1320 E. Passyunk Ave.
          +Philadelphia, PA 19147
          +215-543-6000
          + +• • • • • •

          + +Chicago, IL • Sep 25 - 28 • Wed thru Sat

          + +EndureIt!
          +504 W Fifth Ave
          +Naperville, IL 60563
          +630-305-6771

          + +Running Away Multisport
          +2219 N. Clybourn Ave
          +Chicago, IL 60614
          +773-395-2929

          + +Running Away Multisport
          +800 Waukegan Rd.
          +Deerfield, IL 60015
          +847-945-2929
          +
          + + + +
          +<%include include_content_bottom.html%> +

          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search.html new file mode 100644 index 0000000..cf4e04e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search.html @@ -0,0 +1,72 @@ + + + + <%site_title%>: Search Form +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Search Form

          + +
          +
          + +
          + +
          +
          + +
          + checked="checked" <%endif%>class="radio" /> + checked="checked" <%endif%>class="radio" /> +
          + +
          + checked="checked" <%endif%>class="radio" /> + checked="checked" <%endif%>class="radio" /> +
          + +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search_results.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search_results.html new file mode 100644 index 0000000..96db33d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/search_results.html @@ -0,0 +1,70 @@ + + + + <%site_title%>: Search Results +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Search Results

          + +

          + Your search<%if query%> for <%if highlight%><%set equery = escape_html $query%><%Links::Tools::highlight($equery, $equery)%><%else%><%escape_html query%><%endif%><%endif%> returned <%cat_hits%> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <%link_hits%> link<%if link_hits != 1%>s<%endif%> +

          + +<%if category_results_loop.length~%> +

          Categories

          + +
            +<%~loop category_results_loop%> + <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +
          • <%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%>
          • +<%~endloop%> +
          +<%~endif%> + +<%if link_results_loop.length~%> +

          Links

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<% set search_results_categories = get_links_categories($link_results_loop) %> +<%loop link_results_loop~%> +<%if title_loop.length%> + <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +

          <%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%>

          +<%~endif%> +<%include link.html%> +<%~endloop%> +<%~endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/slowtwitch50_13.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/slowtwitch50_13.html new file mode 100644 index 0000000..924f4d6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/slowtwitch50_13.html @@ -0,0 +1,732 @@ + + + +<%site_title%>: Slowtwitch TBI 50 (2013) +<%include include_common_head.html%> + + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Slowtwitch TBI 50

          +

          + +

          +The list below represents, in order by vote total, the top 50 multisport retailers during 2013. Those in yellow highlight are the top-10 vote getters. These are the top retailers in the United States, as voted by their vendors (80% of the score weight) and consumers (weighted 20%). This list was announced in January, 2014, and this is the second year these retailers have been elected and honored. TBI stands for Triathlon Business International, and is an industry organization comprised of many of triathlon's top manufacturers, race organizers, retailers, media and event services companies. +

          +Ballots were sent out to 75 vendors in every multisport sector: running shoe and bike makers, accessory and swim companies, and distributors. These vendors were asked to choose from among roughly 400 retailers, culled from an original list of about 800 retailers who sell bikes, swim specialty and run specialty. These 400 retailers were split into 9 regions, so that retailers from high-density areas did not dominate the voting. +

          +No voting cohort is ideal. Vendors are in a better position than consumers to judge among retailers in a large area, such as the entire United States, because a consumer in Tennessee cannot fairly assess the value of his local retailers versus those in Vermont or Oregon. Vendors are not perfect, because they tend to too-often vote simply based on sales figures. After much testing, the current 80/20 score weighting seems to yield what seems a fair result. +

          +Vendors were asked to score their ballots based on the following: +

          +- Superior technical and brand knowledge.
          +- Broad and deep tri-related inventory in stock.
          +- Strong service to the local community.
          +- Specific knowledge of triathlon.
          +- Strong ability to match the right product, size, and set-up to the customer.
          +- Strong intangibles (local race and club support, training rides and runs, guest speakers).
          +

          +Just below this list of 50 is the same list sorted by state. +

          +

          +

          + + + +

          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          1All3SportsAtlantaGA
          2Nytro MultisportEncinitasCA
          3Speedy ReedySeattleWA
          4Gear West Bike and TriathlonLong LakeMN
          5Trisports.comTucsonAZ
          6Athletes LoungePortlandOR
          7Austin Tri CyclistAustinTX
          8R&A CyclesBrooklynNY
          9Colorado MultisportBoulderCO
          10Running Away MultisportDeerfieldIL
          11Triathlon LabSanta MonicaCA
          12Inside Out SportsCaryNC
          13Moment Cycle SportSan DiegoCA
          14Tribe MultisportScottsdaleAZ
          15Running Away MultisportChicagoIL
          16Jack and AdamsAustinTX
          17Element MultisportChicagoIL
          18T3 MultisportIndianapolisIN
          19Richardson Bike MartRichardsonTX
          20Inside Out SportsCharlotteNC
          21Podium MultisportAtlantaGA
          22Bonzai SportsFalls ChurchVA
          23Davis WheelworksDavisCA
          24Wheat Ridge CycleryWheat RidgeCO
          25Sunerise TriWest BabylonNY
          26Paragon SportsNYNY
          27SBR MultisportsNYNY
          28Get a Grip CyclesChicagoIL
          29Mack CycleMiamiFL
          30TriBellaBoulderCO
          31Contender BicyclesSalt Lake CityUT
          32Fit Werx 2PeabodyMA
          33Endurance HouseMiddletonWI
          34Fast SplitsNewtonMA
          35Arts CyclerySan Luis ObispoCA
          36ChainwheelLittle RockAK
          37Naperville Running CoNapervilleIL
          38Play TriDallasTX
          39Northwest Tri and BikeKentWA
          40Big Shark Bicycle CompanySt. LouisMO
          41FreshbikesArlingtonVA
          42Belmont WheelworksBelmontMA
          43Brickwell Cycling and MultisportsGreat NeckNY
          44Fleet FeetSacramentoCA
          45Bike DoctorArnoldMD
          46Britton's Bike ShopSan AntonioTX
          47Tri ShopPlanoTX
          48SBR SportsOremUT
          49Tri TownBoiseID
          50Urban Tri GearChicagoIL
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          Sorted by State
          ChainwheelLittle RockAK
          Trisports.comTucsonAZ
          Tribe MultisportScottsdaleAZ
          Nytro MultisportEncinitasCA
          Triathlon LabSanta MonicaCA
          Moment Cycle SportSan DiegoCA
          Davis WheelworksDavisCA
          Arts CyclerySan Luis ObispoCA
          Fleet FeetSacramentoCA
          Colorado MultisportBoulderCO
          Wheat Ridge CycleryWheat RidgeCO
          TriBellaBoulderCO
          Mack CycleMiamiFL
          All3SportsAtlantaGA
          Podium MultisportAtlantaGA
          Tri TownBoiseID
          Running Away MultisportDeerfieldIL
          Running Away MultisportChicagoIL
          Element MultisportChicagoIL
          Get a Grip CyclesChicagoIL
          Naperville Running CoNapervilleIL
          Urban Tri GearChicagoIL
          T3 MultisportIndianapolisIN
          Fit Werx 2PeabodyMA
          Fast SplitsNewtonMA
          Belmont WheelworksBelmontMA
          Bike DoctorArnoldMD
          Gear West Bike and TriathlonLong LakeMN
          Big Shark Bicycle CompanySt. LouisMO
          Inside Out SportsCaryNC
          Inside Out SportsCharlotteNC
          R&A CyclesBrooklynNY
          Sunerise TriWest BabylonNY
          Paragon SportsNYNY
          SBR MultisportsNYNY
          Brickwell Cycling and MultisportsGreat NeckNY
          Athletes LoungePortlandOR
          Austin Tri CyclistAustinTX
          Jack and AdamsAustinTX
          Richardson Bike MartRichardsonTX
          Play TriDallasTX
          Britton's Bike ShopSan AntonioTX
          Tri ShopPlanoTX
          Contender BicyclesSalt Lake CityUT
          SBR SportsOremUT
          Bonzai SportsFalls ChurchVA
          FreshbikesArlingtonVA
          Speedy ReedySeattleWA
          Northwest Tri and BikeKentWA
          Endurance HouseMiddletonWI
          +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/stackreach.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/stackreach.html new file mode 100644 index 0000000..1338f78 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/stackreach.html @@ -0,0 +1,40 @@ + + + + <%site_title%>: Stack & Reach Database +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +<%--div class="crumb"><%Links::Utils::format_title($title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%> +

          Stack & Reach Database

          + +<%include include_stack_reach_content.html%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/subcategory.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/subcategory.html new file mode 100644 index 0000000..15cb9cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/local/subcategory.html @@ -0,0 +1,2 @@ +
          <%if RelationName%><%RelationName%><%else%><%Name%><%endif%><%if Related%>@<%endif%> <%--(<%Number_of_Links%>)--%><%if Has_New_Links eq 'Yes'%> new<%endif%><%if Has_Changed_Links eq 'Yes'%> updated<%endif%>
          +<%if Description%>
          <%Description%>
          <%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login.html new file mode 100644 index 0000000..ae277ee --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login.html @@ -0,0 +1,86 @@ + +<%~if error%> + <%~-- Move $error into $message. Done for backwards compatibility with Links SQL 2.x templates. --%> + <%~if logout or send_pass or send_validate%> + <%~set message = $error%> + <%~set error = ''%> + <%~endif%> +<%~endif%> +<%~if url and not error%> + <%~set error = 'You must first login before you can access that.'%> +<%~endif%> + + + <%site_title%>: User Login +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          User Login

          + +

          Login to <%site_title%>:

          + +
          + + <%if url%><%endif%> + +
          + +
          + +
          +
          +
          + +
          + +
          +
          +<%~if config.user_sessions eq Cookies%> +
          + +
          + checked="checked"<%endif%> class="checkbox" /> +
          +
          +<%~endif%> +
          + +
          +
          + +

          + If you don't have an account, please register.
          +<%~if config.user_allow_pass%> + If you've forgotten your password, we can e-mail it to you. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_email.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_email.html new file mode 100644 index 0000000..dafe235 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_email.html @@ -0,0 +1,61 @@ + + + + <%site_title%>: Forgotten Password +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Forgot your password?

          + +

          + Simply enter your e-mail address that you signed up with and we will e-mail you your password. +

          + +
          + + <%if url%><%endif%> + +
          + +
          + +
          +
          +
          + +
          +
          + +

          + If you don't have an account, please register. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_success.html new file mode 100644 index 0000000..3b4e38e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/login_success.html @@ -0,0 +1,48 @@ + + + + <%site_title%>: Logged In +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Logged In

          + +

          + You have been successfully logged into <%site_title%>. +

          + +<%if not d and Links::Utils::is_editor%> +

          + Enter the editor system. +

          +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify.html new file mode 100644 index 0000000..e89bd38 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify.html @@ -0,0 +1,86 @@ + + + + <%site_title%>: Modify a Link +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Modify a Link

          + +
          + +<%~if LinkID%> + + +<%~else%> + <%~if config.db_gen_category_list == 2%> + + + + <%~endif%> +

          + Enter the new information (all of it, not just the changes) below: +

          +<%~endif%> +<%include include_form.html%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_select.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_select.html new file mode 100644 index 0000000..f3a5024 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_select.html @@ -0,0 +1,54 @@ + + + + <%site_title%>: Modify a Link +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Modify a Link

          + +

          + Please select which link you would like to modify: +

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +
          +<%~loop link_results_loop%> + disabled="disabled"<%endif%> /> +<%include link.html%> +<%~endloop%> + +
          + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_success.html new file mode 100644 index 0000000..30d895e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/modify_success.html @@ -0,0 +1,79 @@ + + + + <%site_title%>: Link Modified +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Link Modified

          + +

          +<%~if payment_term eq free%> + Your link has been changed to a free link: +<%~else%> + We have received your request to modify the link as follows: +<%~endif%> +

          + +
          + +
          <%Title%>
          +
          +
          + +
          <%escape_html URL%>
          +
          +
          + +
          + <%~if Category_loop.length > 1%> +
            <%loop Category_loop%>
          • <%loop_value%>
          • <%endloop%>
          + <%~else%> + <%Category%> + <%~endif%> +
          +
          +
          + +
          <%escape_html Description%>
          +
          +
          + +
          <%escape_html Contact_Name%>
          +
          +
          + +
          <%escape_html Contact_Email%>
          +
          + +<%if not config.user_direct_mod and payment_term ne free%>

          Thank you! We will send you an e-mail once your link has been validated.

          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/new.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/new.html new file mode 100644 index 0000000..2b58281 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/new.html @@ -0,0 +1,68 @@ + + + + <%site_title%>: New Links +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          New Links

          + +<%-- Displays a list of dates and counts for each link --~%> +<%if new_index~%> +
            +<%~loop link_results_loop%> +
          • <%date%> (<%count%>)
          • +<%endloop~%> +
          +<%~-- Displays the new links without span pages --~%> +<%~elsif title_linked_loop%> +<%~loop title_linked_loop%> + <%new_date%> + <%loop links%> +

          <%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%>

          +<%include link.html%> + <%~endloop%> +<%~endloop%> +<%~-- Displays the actual new links --~%> +<%else%> +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%if link_results_loop%> +<%loop link_results_loop%> +<%Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +<%include link.html%> +<%endloop%> +<%endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter.html new file mode 100644 index 0000000..998ac7b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter.html @@ -0,0 +1,45 @@ + +<%set error_message = $error~%> +<%set error = ''~%> +<%set info_message = $message~%> +<%set message = ''~%> + + + <%site_title%>: Newsletter +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Newsletter

          + +<%if error_message%>

          <%error_message%>

          <%endif%> +<%if info_message%>

          <%info_message%>

          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_browse.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_browse.html new file mode 100644 index 0000000..a04ffd6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_browse.html @@ -0,0 +1,112 @@ + +<%Links::Newsletter::browse%> + + + <%site_title%>: Newsletter +<%include include_common_head.html%> + + + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Newsletter

          + +

          + Check the boxes of categories you'd like to subscribe to and click "Update Subscriptions." + Click on a category's name to see subcategories. Periodically, you'll + receive an e-mail informing you of updates to your subscribed categories. + You can Unsubscribe + from any or all categories at any time. +

          + +<%if PPID ne ''%>Back to <%PPName%>
          <%endif%> + +
          + + <%if root%><%endif%> +<%~loop category%> + checked="checked"<%endif%> class="indent<%CatDepth%>" /><%if HasMoreChildren%><%endif%><%Name%><%if HasMoreChildren%><%endif%>
          +<%~endloop%> + +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_global.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_global.html new file mode 100644 index 0000000..54a48cc --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_global.html @@ -0,0 +1,48 @@ + +<%Links::Newsletter::global_subscribe_info%> + + + <%site_title%>: Newsletter +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Newsletter

          + +

          + <%if subscribed%>You are subscribed to the newsletter.<%else%>You aren't subscribed to the newsletter.<%endif%> +

          + +
          + + +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_list.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_list.html new file mode 100644 index 0000000..e98e7c6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/newsletter_list.html @@ -0,0 +1,67 @@ + +<%Links::Newsletter::list_subscribed%> + + + <%site_title%>: Newsletter +<%include include_common_head.html%> + + + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Newsletter

          + +

          + Check the boxes of categories you no longer wish to recieve updates about and + click "Unsubscribe." You can subscribe to categories using the Newsletter + Category Browser. +

          + +<%~if subscribed.length%> +
          + + + <%if subscribed.length > 1%>
          <%endif%> +<%loop subscribed~%> +
          +<%~endloop%> + +
          +<%~else%> +

          + You aren't subscribed to any categories. +

          +<%~endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/password.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/password.eml new file mode 100644 index 0000000..f96fb94 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/password.eml @@ -0,0 +1,27 @@ +To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your password you requested + +Hello<%if Name%> <%Name%><%endif%>, + +Someone (most likely you) from the IP <%REMOTE_ADDR%> +requested your username and password. + +You can log into our directory with: + + Username: <%Username%> + Password: <%Password%> + +Hope that helps, + +<%site_title%> + +<%~-- + File : password.eml + Description : This is the e-mail a user receives when they request that + their password is e-mailed to them + Tags : All the properties of the User that requested the + password mailing are available. Also environment variables + like REMOTE_HOST and REMOTE_ADDR are available for + printing the IP of the user who requested the mailing. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment.html new file mode 100644 index 0000000..8491ea7 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment.html @@ -0,0 +1,127 @@ + + + + <%site_title%>: Payment +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Payment

          + +<%include link.html%> + +

          +<%~if payment_mode == 2%> + You have the option of paying to have your link displayed at the top of this category. Choose a payment selection listed below, or choose to submit it as a free link, and click "Next". +<%~else%> + You are required to make a payment to add a link to this category. Choose one of the payment methods listed below and click "Next" to make a payment. +<%~endif%> +

          + +

          + <%if Payment_Description%><%Payment_Description%><%else%><%payment_description%><%endif%> +

          + +<%if discount_description~%> +

          + <%discount_description%> +

          +<%~elsif discount_percent%> +

          + Payment costs have been discounted by <%discount_percent%>% for this link. +

          +<%~endif%> + +
          + + + + + + + <%if modify%><%endif%> + +<%if signup and not wasPaid%> +

          + + <%~if renewal_differs%> + Initial payment: + <%~else%> + Single Payment: + <%~endif%> +
          + <%~loop signup%> + checked="checked"<%endif%> class="radio" /> +
          + <%~endloop%> +

          +<%endif%> + +<%if renewal_differs or wasPaid%> +

          + <%~if wasPaid%> + Renewal payment:
          + <%~elsif recurring and Links::Payment::recurring_enabled%> + If using a single payment, the following renewal options are available after making the initial payment:
          + <%~else%> + The following renewal options are available after making the initial payment:
          + <%~endif%> + +<%~loop renewal%> + <%if wasPaid%> checked="checked"<%endif%> class="radio" /><%endif%> + <%if wasPaid%><%endif%>
          +<%~endloop%> +

          +<%endif%> + +<%if recurring and Links::Payment::recurring_enabled%> +

          + Automatically recurring payments:
          + <%~loop recurring%> + checked="checked"<%endif%> class="radio" /> +
          + <%~endloop%> +

          +<%endif%> + +<%if payment_mode == 2%> +

          + No thanks, submit this as a free link
          + + +

          +<%endif%> + +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_2checkout_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_2checkout_include.html new file mode 100644 index 0000000..92a7720 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_2checkout_include.html @@ -0,0 +1,13 @@ +
          + + + + + +<%~-- This will only work if this matches the domain set up with 2Checkout: https://support.2co.com/deskpro/faq.php?do=article&articleid=363 --%> + +<%~if demo%> + +<%~endif%> + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct.html new file mode 100644 index 0000000..2b2662a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct.html @@ -0,0 +1,45 @@ + + + + <%site_title%>: Payment Confirmation + " /> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Payment Confirmation

          + +

          + Your payment has been approved, and your link enabled. You will be redirected + to the main page shortly. If this does not happen, click + here. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct_include.html new file mode 100644 index 0000000..32d4632 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_direct_include.html @@ -0,0 +1,125 @@ +

          + Please enter your credit card and billing information in the fields below. Fields marked with * are required. +

          + +<%if payment_declined%> +

          Your payment was declined: <%payment_errmsg%>

          +<%~elsif payment_erred%> +

          An error occured while processing your payment: <%payment_errmsg%>

          +<%~endif%> + +
          + + + + + + + + + + <%if modify%><%endif%> + +
          + +
          + <%if no_cc_brand%> + <%loop payment_types%><%name%><%unless last%>, <%endunless%><%endloop%> + <%else%> + + <%endif%> +
          +
          +
          + +
          + +
          +
          +
          + +
          + / + <%Links::Payment::next_years(10)%><%-- Show the next 10 years --%> + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +<%~if billing_phone_required%> +
          + +
          + +
          +
          +<%~endif%> +
          + +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_form.html new file mode 100644 index 0000000..18e8c41 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_form.html @@ -0,0 +1,63 @@ + + + + <%site_title%>: Payment +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Payment

          + +<%if payment_description%>

          <%payment_description%>

          <%endif%> + +<%if payment_amount%> +

          + Payment: + <%if payment_type == 2%><%-- Recurring --%> + <%Links::Payment::currency($payment_amount)%> <%if payment_term_num == 1%>per<%else%>every <%payment_term_num%><%endif%> <%payment_term_unit%> + <%~else%> +<%Links::Payment::currency($payment_amount)%> - <%if payment_term_num and payment_term_unit%><%payment_term_num%> <%payment_term_unit%><%else%>Lifetime<%endif%> + <%~endif%> +

          +<%~endif%> + +<%if payment_direct%> +<%include payment_direct_include.html%> +<%elsif payment_method eq 'PayPal'%> +<%include payment_paypal_include.html%> +<%elsif payment_method eq 'WorldPay'%> +<%include payment_worldpay_include.html%> +<%elsif payment_method eq '2CheckOut'%> +<%include payment_2checkout_include.html%> +<%elsif payment_method eq 'Manual'%> +<%include payment_manual_include.html%> +<%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_manual_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_manual_include.html new file mode 100644 index 0000000..32d69e5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_manual_include.html @@ -0,0 +1,12 @@ +<%Links::Payment::Remote::Manual::insert_log($unique_id)%> +<%-- You should replace the following with your own message on how/where they should send payments --%> +

          + Your payment will be manually approved by the Administrator when your + payment has been received. Please include the following information + with your payment: +

          +

          + Link ID: <%escape_html ID%>
          + Payment ID: <%escape_html unique_id%> +

          +'" /> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_method.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_method.html new file mode 100644 index 0000000..1cdea4b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_method.html @@ -0,0 +1,86 @@ + +<%set using_direct_methods = Links::Payment::direct_methods_used()~%> +<%set definitely_https = Links::https()~%> + + + <%site_title%>: Payment +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Payment

          + +<%~if using_direct_methods and not definitely_https%> +

          + If your browser does not indicate that you are in a secure environment (usually indicated by a padlock icon at the bottom of the browser window), visit the secure version of this page. +

          +<%~endif%> + +<%if payment_description%>

          <%payment_description%>

          <%endif%> + +<%if payment_amount%> +

          + Payment: + <%if payment_type == 2%><%-- Recurring --%> + <%Links::Payment::currency($payment_amount)%> <%if payment_term_num == 1%>per<%else%>every <%payment_term_num%><%endif%> <%payment_term_unit%> + <%~else%> + <%Links::Payment::currency($payment_amount)%> - <%if payment_term_num%><%payment_term_num%> <%payment_term_unit%><%else%>Lifetime<%endif%> + <%~endif%> +

          +<%~endif%> + +<%unless error%>

          Please choose a payment method below to continue:

          <%endif%> + +
          + + + + + + + + <%if modify%><%endif%> + +<%~if direct_methods_used or remote_methods_used%> +<%~loop payment_methods%> + +
          +
          <%loop payment_types%><%name%><%unless last%>, <%endunless%><%endloop%>
          +<%~endloop%> +<%~else%> +

          Error: There are no payment methods which support your selected payment term.

          +<%~endif%> + +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_paypal_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_paypal_include.html new file mode 100644 index 0000000..97af308 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_paypal_include.html @@ -0,0 +1,26 @@ +
          + + + + + + + <%if notify_url%><%endif%> + <%if pp_image_url%><%endif%> + <%if note and payment_type != 2 %><%else%><%endif%> + <%if color eq 'black'%><%endif%> + +<%~if payment_type == 2%> + + + + + +<%~else%> + +<%~endif%> + + + + +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_received.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_received.eml new file mode 100644 index 0000000..b4a8cce --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_received.eml @@ -0,0 +1,34 @@ +To: <%if Contact_Email%><%if Contact_Name%>"<%Contact_Name%>" <<%Contact_Email%>><%else%><%Contact_Email%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Payment has been received and your link has been added + +Hello<%if Contact_Name%> <%Contact_Name%><%elsif Name%> <%Name%><%endif%>, + +Thank you for visiting our site. Your payment has been processed and +your link has been added to our directory: + + Title: <%Title%> + URL: <%URL%> + Category: <%Category%> + Description: <%Description%> + Contact Name: <%Contact_Name%> + Contact E-mail: <%Contact_Email%> + +You can see your new listing at: + + <%config.build_root_url%>/<%home_index%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : payment_received.eml + Description : This is the e-mail a user receives when their payment has + been processed and the link has been added. + Tags : All the properties of the link that was just added are + available plus: + Category => The category the link was added to. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_success.html new file mode 100644 index 0000000..1e6451c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_success.html @@ -0,0 +1,44 @@ + + + + <%site_title%>: Payment Confirmation + " /> +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Payment Confirmation

          + +

          + Your payment has been approved. You will be redirected to the main page shortly. + If this does not happen, click here. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_worldpay_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_worldpay_include.html new file mode 100644 index 0000000..362e444 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/payment_worldpay_include.html @@ -0,0 +1,21 @@ +
          + + <%if test_mode%><%endif%> + + +<%~if payment_type = 2%> + + + + + + + +<%~endif%> + + + + + +
          + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/pictureframe.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/pictureframe.html new file mode 100644 index 0000000..d360903 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/pictureframe.html @@ -0,0 +1,90 @@ +<%Plugins::SlideShow::generate_paths( $ID )%> + + + + +<%site_title%>: <%Title%> + + + + + +<%body_tag%> +
          + + + + + + + + +
          + + + + + + +
          + + + + + + +
          +
          +
          +
          + + + + + + + + + + + + + + + + + + + +
          <%body_font%> + <%if Image_First%>Jump to first<%endif%>  + <%if Image_Previous%>Previous<%endif%> + <%body_font%> + <%loop Image_Tool%> +   + <%if Image_Selected%> + <%Image_Index%> + <%else%> + <%Image_Index%> + <%endif%> + <%endloop%> + <%body_font%> + <%if Image_Next%>Next<%endif%>  + <%if Image_Last%>Jump to end<%endif%> +
          + <%body_font%> +
          <%body_font%><%if Image_Description%><%Image_Description%><%else%><%Title%><%endif%> +
          + Currently viewing image <%Image_Current%> of <%Image_Count%> +
          +
          + +
          + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate.html new file mode 100644 index 0000000..a79cbfe --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate.html @@ -0,0 +1,68 @@ + + + + <%site_title%>: Rate a Link +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Rate a Link

          + +

          + Please rate the link <%if detailed_url%><%elsif URL ne 'http://'%><%endif%><%Title%><%if detailed_url or URL ne 'http://'%><%endif%> between one (worst) and ten (best). +

          + +
          + + +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_success.html new file mode 100644 index 0000000..af6f1ad --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_success.html @@ -0,0 +1,42 @@ + + + + <%site_title%>: Rate a Link +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Rate a Link

          + +

          + Thank you for your vote. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_top.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_top.html new file mode 100644 index 0000000..bdac99b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/rate_top.html @@ -0,0 +1,72 @@ + + + + <%site_title%>: Top Rated Links +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Top Rated Links

          + +

          Top 10 by rating (10 or more votes)

          + + + + + + + +<%~loop top_rated_loop%> + + + + + +<%~endloop%> +
          RatingVotesLink
          <%Rating%><%Votes%><%if detailed_url%><%elsif URL ne 'http://'%><%endif%><%Title%><%if detailed_url or URL ne 'http://'%><%endif%>
          + +

          Top 10 by votes (10 or more votes)

          + + + + + + + +<%~loop top_votes_loop%> + + + + + +<%~endloop%> +
          RatingVotesLink
          <%Rating%><%Votes%><%if detailed_url%><%elsif URL ne 'http://'%><%endif%><%Title%><%if detailed_url or URL ne 'http://'%><%endif%>
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add.html new file mode 100644 index 0000000..8bdf71f --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add.html @@ -0,0 +1,95 @@ + + + + <%site_title%>: Add a Review +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Add a Review

          + +<%if URL%><%include link.html%><%endif%> + +

          + Please completely fill out the form below, and we'll add your review as soon as possible. +

          + +
          + <%if ID%><%endif%> + +
          + +
          + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +<%~if not config.user_review_required and not user.Username%> +
          + +
          + +
          +
          + +
          + +
          + +
          +
          +<%~endif%> +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add_success.html new file mode 100644 index 0000000..05b4e86 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_add_success.html @@ -0,0 +1,79 @@ + + + + <%site_title%>: Review Added +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Review Added

          + +

          + We have received the following review: +

          + +<%~if Review_Rating%> +
          + +
          <%escape_html Review_Rating%>
          +
          +<%~endif%> +
          + +
          <%escape_html Review_Subject%>
          +
          +
          + +
          <%escape_html Review_ByLine%>
          +
          +
          + +
          <%if config.review_convert_br_tags%><%Review_Contents%><%else%><%escape_html Review_Contents%><%endif%>
          +
          +<%~if not config.user_review_required and not user.Username%> +
          + +
          <%escape_html Review_GuestName%>
          +
          +
          + +
          <%escape_html Review_GuestEmail%>
          +
          +<%~endif%> + +

          +<%~if config.review_auto_validate%> + Thank you! Your review has been added. +<%~else%> + Thank you! We will send you an e-mail once your review has been validated. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_added.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_added.eml new file mode 100644 index 0000000..2338b67 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_added.eml @@ -0,0 +1,38 @@ +To: <%if Review_GuestEmail%><%if Review_GuestName%>"<%Review_GuestName%>" <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your review has been approved + +Hello<%if Review_GuestName%> <%Review_GuestName%><%elsif Name%> <%Name%><%endif%>, + +Thank you for visiting our site. We've added the following review into +our directory: + +<%~if Review_Rating%> + Rating: <%Review_Rating%> +<%~endif%> + Subject: <%Review_Subject%> + By Line: <%Review_ByLine%> + Date: <%Review_Date%> + Contents: <%Review_Contents%> +<%~if not config.user_review_required and not user.Username%> + Name: <%Review_GuestName%> + E-mail: <%Review_GuestEmail%> +<%~endif%> + +of the link: + + <%URL%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : review_added.eml + Description : This is the e-mail a user receives when their link is + validated. + Tags : All the properties of the review and the link (was + reviewed) that was just validated are available. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit.html new file mode 100644 index 0000000..7086a9d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit.html @@ -0,0 +1,93 @@ + + + + <%site_title%>: Edit Review +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Edit Review

          + +<%if URL%><%include link.html%><%endif%> + +

          +<%~if confirm%> + You have already submitted a review for this link. Press "Continue" to edit your review. +<%~else%> + Please edit your review below, and we'll update your review as soon as possible. +<%~endif%> +

          + +
          + + +<%~if confirm%> +
          + + +
          +<%~else%> + + +
          + +
          + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> + checked="checked"<%endif%> class="radio" /> +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          +<%~endif%> +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit_success.html new file mode 100644 index 0000000..ef8c35c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_edit_success.html @@ -0,0 +1,69 @@ + + + + <%site_title%>: Review Updated +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Review Updated

          + +

          + We have received the following review: +

          + +<%~if Review_Rating%> +
          + +
          <%escape_html Review_Rating%>
          +
          +<%~endif%> +
          + +
          <%escape_html Review_Subject%>
          +
          +
          + +
          <%escape_html Review_ByLine%>
          +
          +
          + +
          <%if config.review_convert_br_tags%><%Review_Contents%><%else%><%escape_html Review_Contents%><%endif%>
          +
          + +

          +<%~if config.review_auto_validate%> + Your review has been modified. +<%~else%> + Thank you! We will send you an e-mail once your review has been validated. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_include.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_include.html new file mode 100644 index 0000000..a5b58c8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_include.html @@ -0,0 +1,47 @@ +
          +<%~if show_link_info%> + <%~set ID = $LinkID%> + <%~Links::Utils::load_link_info%> +<%include link.html%> + <%~set ID = ''%> +<%~endif%> +

          + <%escape_html Review_Subject%><%if Review_CanModify%> (edit)<%endif%> + " alt="<%Review_Rating%> out of 5 stars" title="<%Review_Rating%> out of 5 stars" /> + <%if Review_IsNew%>new<%endif%> +

          +<%~if Review_ByLine%> +
          + <%escape_html Review_ByLine%> +
          +<%~endif%> +

          + Reviewed by: <%if Review_GuestName%><%Review_GuestName%><%else%><%Review_Owner%><%endif%>, <%Review_Date%><%if Review_ModifyDate%> (Modified: <%Review_ModifyDate%>)<%endif%> +

          +<%~if Review_Contents%> +
          + <%~if config.review_convert_br_tags%> + <%Review_Contents%> + <%~else%> + <%escape_html Review_Contents%> + <%~endif%> +
          +<%~endif%> +
          + <%if Num%><%Review_WasHelpful%> of <%Num%> people found this review helpful<%endif%> +
          + <%if nh and nh != 1%><%endif%> + + <%if ID%><%endif%> + <%if username%><%endif%> + <%if ReviewID%><%endif%> + + <%~if last_helpful%> + Thanks for the feedback. + <%~else%> + Was this review helpful to you? + <%~endif%> + +
          +
          +
          diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_rejected.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_rejected.eml new file mode 100644 index 0000000..f2a4033 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_rejected.eml @@ -0,0 +1,31 @@ +To: <%if Review_GuestEmail%><%if Review_GuestName%>"<%Review_GuestName%>" <<%Review_GuestEmail%>><%else%><%Review_GuestEmail%><%endif%><%elsif Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your review has been rejected + +Hello<%if Review_GuestName%> <%Review_GuestName%><%elsif Name%> <%Name%><%endif%>, + +Your review: + + <%Review_Subject%> + +of the link: + + <%URL%> + +that was submitted on <%Review_Date%> has been rejected +for one of the following reasons: + + 1. Unsuitable content. + +If you have any questions, please don't hesitate to ask. + +<%site_title%> + +<%~-- + File : review_rejected.eml + Description : This is the e-mail a user receives when their review is + rejected. It can be customized by the admin prior to + sending. + Tags : All the properties of the review and the link (was + reviewed) that was rejected are available. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_search_results.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_search_results.html new file mode 100644 index 0000000..f689f60 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/review_search_results.html @@ -0,0 +1,58 @@ + + + + <%site_title%>: Reviews +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Reviews

          + +<%unless error%> +<%if username%> +

          <%if username eq $user.Username%>My Reviews<%else%>Reviews written by <%username%><%endif%> (<%Review_Count%> review<%if Review_Count != 1%>s<%endif%>)

          +<%elsif ID%> +<%include link.html%> +<%endif%> +<%endunless%> + +<%if Review_Loop.length~%> +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%loop Review_Loop~%> +<%include review_include.html%> +<%~endloop%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> +<%~endif%> + +<%if ID and not error%>

          Add your own Review

          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search.html new file mode 100644 index 0000000..cf4e04e --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search.html @@ -0,0 +1,72 @@ + + + + <%site_title%>: Search Form +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Search Form

          + +
          +
          + +
          + +
          +
          + +
          + checked="checked" <%endif%>class="radio" /> + checked="checked" <%endif%>class="radio" /> +
          + +
          + checked="checked" <%endif%>class="radio" /> + checked="checked" <%endif%>class="radio" /> +
          + +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search_results.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search_results.html new file mode 100644 index 0000000..3db7b81 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/search_results.html @@ -0,0 +1,69 @@ + + + + <%site_title%>: Search Results +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Search Results

          + +

          + Your search<%if query%> for <%if highlight%><%set equery = escape_html $query%><%Links::Tools::highlight($equery, $equery)%><%else%><%escape_html query%><%endif%><%endif%> returned <%cat_hits%> categor<%if cat_hits != 1%>ies<%else%>y<%endif%> and <%link_hits%> link<%if link_hits != 1%>s<%endif%> +

          + +<%if category_results_loop.length~%> +

          Categories

          + +
            +<%~loop category_results_loop%> + <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +
          • <%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%>
          • +<%~endloop%> +
          +<%~endif%> + +<%if link_results_loop.length~%> +

          Links

          + +<%if paging.num_hits%>
          <%Links::Utils::paging()%>
          <%endif%> + +<%loop link_results_loop~%> +<%if title_loop.length%> + <%~set formatted_title = Links::Utils::format_title($title_loop, separator => $category_separator, no_escape_separator => $no_escape_category_separator, include_home => 0, link_type => 1)%> +

          <%if highlight and query%><%Links::Tools::highlight($formatted_title, $query)%><%else%><%formatted_title%><%endif%>

          +<%~endif%> +<%include link.html%> +<%~endloop%> +<%~endif%> + +<%if paging.num_hits%>
          <%Links::Utils::paging(button_id => 'paging_button2')%>
          <%endif%> + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_form.html new file mode 100644 index 0000000..3daeda2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_form.html @@ -0,0 +1,66 @@ + + + + <%site_title%>: User Sign Up +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          User Sign Up

          + +

          + To register, please fill out this form completely. A valid e-mail address is required. +

          + +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_success.html new file mode 100644 index 0000000..e90b29d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/signup_success.html @@ -0,0 +1,47 @@ + +<%~set message = 'Registration successful'%> + + + <%site_title%>: Successful Sign Up +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Successful Sign Up

          + +

          +<%~if Validation%> + Thanks for signing up, an e-mail has been sent to you with a validation code. Once you receive it, you'll need to enter a validation code +<%~else%> + You are now logged into <%site_title%> as '<%escape_html user.Username%>'. +<%~endif%> +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/subcategory.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/subcategory.html new file mode 100644 index 0000000..24e4c58 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/subcategory.html @@ -0,0 +1,2 @@ +
          <%if RelationName%><%RelationName%><%else%><%Name%><%endif%><%if Related%>@<%endif%> (<%Number_of_Links%>)<%if Has_New_Links eq 'Yes'%> new<%endif%><%if Has_Changed_Links eq 'Yes'%> updated<%endif%>
          +<%if Description%>
          <%Description%>
          <%endif%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/treecats.xml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/treecats.xml new file mode 100644 index 0000000..badf020 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/treecats.xml @@ -0,0 +1,18 @@ +"?> + +<%~if error%> + ]]> +<%~endif%> +<%~loop categories%> + + ]]> + ]]> + +<%~endloop%> +<%~loop links%> + + ]]> + <%unescape_html URL%><%endif%>]]> + +<%~endloop%> + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate.eml b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate.eml new file mode 100644 index 0000000..b0c0ac5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate.eml @@ -0,0 +1,29 @@ +To: <%if Name%>"<%Name%>" <<%Email%>><%else%><%Email%><%endif%> +From: <%config.db_admin_email%> +Subject: Your validation code + +Hello<%if Name%> <%Name%><%endif%>, + +Thank you for registering. To activate your account, simply go to: + + <%config.db_cgi_url%>/user.cgi?validate=1 + +and enter the following code: + + <%Validation%> + +Should you have any questions, please don't hesitate to ask. + +Sincerely, + +<%site_title%> + +<%~-- + File : validate.eml + Description : This is the e-mail a user receives when they have signed + up, but must validate their account. + Tags : All the properties of the User requesting validation are + available plus: + Validation => The code the user must enter to validate + their account. +--%> diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_form.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_form.html new file mode 100644 index 0000000..618e9d3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_form.html @@ -0,0 +1,55 @@ + + + + <%site_title%>: Validation +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Validation

          + +

          + To validate your account, please enter the validation code you received: +

          + +
          + +
          + +
          + +
          +
          +
          + +
          +
          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_success.html b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_success.html new file mode 100644 index 0000000..17c11b3 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/luna/validate_success.html @@ -0,0 +1,42 @@ + + + + <%site_title%>: Account Activated +<%include include_common_head.html%> + + +<%include include_accessibility.html%> +
          +<%include include_header.html%> +<%include include_contentheader.html%> +
          +
          +<%include include_leftsidebar.html%> +
          +<%include include_contentwrapper_top.html%> +
          +
          +
          +<%include include_content_top.html%> + +
          <%Links::Utils::format_title($main_title_loop, separator => $crumb_separator, no_escape_separator => $no_escape_crumb_separator, include_home => 1, link_type => 2)%>
          +

          Account Activated

          + +

          + Thank you, your account is now activated. +

          + +<%include include_content_bottom.html%> +
          +
          +
          +<%include include_contentwrapper_bottom.html%> +
          +<%include include_rightsidebar.html%> +
          +
          +<%include include_contentfooter.html%> +<%include include_footer.html%> +
          + + diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/templates/twitch b/site/slowtwitch.com/cgi-bin/articles/admin/templates/twitch new file mode 120000 index 0000000..bb7ec94 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/templates/twitch @@ -0,0 +1 @@ +/var/home/slowtwitch/site/articles \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/admin/twitter.cgi b/site/slowtwitch.com/cgi-bin/articles/admin/twitter.cgi new file mode 100755 index 0000000..ca21bc6 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/admin/twitter.cgi @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/:objects/; + +$| = 1; +local $SIG{__DIE__} = \&Links::fatal; +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +use Net::Twitter; +#use Scalar::Util 'blessed'; + +use Plugins::SocialMedia; + +my $id = 4003; +Plugins::SocialMedia::post_twitter($id); +exit; + + +# When no authentication is required: +my $nt = Net::Twitter->new(legacy => 0); + +my $consumer_key = "u4xwsqHZBKrdWYPrKCm8Lw"; +my $consumer_secret = "vjDF6FjeoPJW0WVwgqMEJeuJzilgSIu5QbPGQnWrMI"; +my $token = "1921299666-fMicJMBunBjgBb4ieszHo6tYV0mQcbbaMZU5wSB"; +my $token_secret = "Ko9gPpBaLxqQj6u68EWdlgnPinGSseVzrzUvytWric"; + +# As of 13-Aug-2010, Twitter requires OAuth for authenticated requests +$nt = Net::Twitter->new( + traits => [qw/API::RESTv1_1/], + consumer_key => $consumer_key, + consumer_secret => $consumer_secret, + access_token => $token, + access_token_secret => $token_secret, +); + +my $result = $nt->update('Hello, world2!'); +use Data::Dumper; +print Dumper($result); +exit; + +=tag +eval { + my $statuses = $nt->friends_timeline({ since_id => $high_water, count => 100 }); + for my $status ( @$statuses ) { + print "$status->{created_at} <$status->{user}{screen_name}> $status->{text}\n"; + } +}; +if ( my $err = $@ ) { + die $@ unless blessed $err && $err->isa('Net::Twitter::Error'); + + warn "HTTP Response Code: ", $err->code, "\n", + "HTTP Message......: ", $err->message, "\n", + "Twitter error.....: ", $err->error, "\n"; +} +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/bases.pm b/site/slowtwitch.com/cgi-bin/articles/bases.pm new file mode 100644 index 0000000..5dd55e8 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/bases.pm @@ -0,0 +1,109 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# bases +# Author: Scott Beck +# CVS Info : 087,071,086,086,085 +# $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== + +package bases; + +use strict 'subs', 'vars'; + +sub import { + my $class = shift; + my $pkg = caller; + my $hsh = {@_}; + my @indices = map { $_[$_ * 2] } 0 .. $#_ * 0.5; + foreach my $base (@indices) { + next if $pkg->isa($base); + push @{"$pkg\::ISA"}, $base; + my $args = ''; + if (my $ref = ref $hsh->{$base}) { + require GT::Dumper; + if ($ref eq 'ARRAY') { + $args = '(@{' . GT::Dumper->dump_structure($hsh->{$base}) . '})'; + } + else { + $args = '(' . GT::Dumper->dump_structure($hsh->{$base}) . ')'; + } + } + elsif (defined $hsh->{$base}) { + $args = $hsh->{$base} eq '' ? '()' : "qw($hsh->{$base})"; + } + my $dcl = qq| + package $pkg; + use $base $args; + |; + eval $dcl; + die "$@: $dcl" if $@ && $@ !~ /^Can't locate .*? at \(eval /; + unless (%{"$base\::"}) { + require Carp; + Carp::croak( +qq|Base class package "$base" is empty. +String: +$dcl +\t(Perhaps you need to 'use' the module which defines that package first.)| + ); + } + } +} + +1; + +__END__ + +=head1 NAME + +base - Establish IS-A relationship with base class at compile time. + +=head1 SYNOPSIS + + package Baz; + use bases + Foo => ':all', + Bar => '' + Bat => undef; + +=head1 DESCRIPTION + +Roughly similar in effect to + + package Baz; + use Foo qw(:all); + use Bar(); + use Bat; + BEGIN { @ISA = qw(Foo Bar Bat) } + +This is very similar to C pragma except %FIELDS is not +supported and you are able to pass parameters to import on the +module that is used in this way. + +If the value specified is undef, the module being used import method +will be called if it exists. If the value is an empty string, import +will not be called. + +When strict 'vars' is in scope I also let you assign to @ISA +without having to declare @ISA with the 'vars' pragma first. + +If any of the base classes are not loaded yet, I silently +Cs them. Whether to C a base class package is +determined by the absence of a global $VERSION in the base package. +If $VERSION is not detected even after loading it, will +define $VERSION in the base package, setting it to the string +C<-1, set by bases.pm>. + +=head1 COPYRIGHT + +Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +http://www.gossamer-threads.com/ + +=head1 VERSION + +Revision: $Id: bases.pm,v 1.10 2011/05/13 23:56:51 brewt Exp $ + +=cut + diff --git a/site/slowtwitch.com/cgi-bin/articles/bookmark.cgi b/site/slowtwitch.com/cgi-bin/articles/bookmark.cgi new file mode 100755 index 0000000..9c62d4a --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/bookmark.cgi @@ -0,0 +1,31 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: bookmark.cgi,v 1.4 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$CFG $IN $PLG/; +use Links::Bookmark; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if (not $CFG->{bookmark_enabled}) { + print $IN->header(); + print Links::SiteHTML::display('bookmark_error', { error => Links::language('BOOKMARK_DISABLED') }); +} +elsif ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_bookmark', \&Links::Bookmark::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/browser.cgi b/site/slowtwitch.com/cgi-bin/articles/browser.cgi new file mode 100755 index 0000000..6d17416 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/browser.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: browser.cgi,v 1.25 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Editor; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_editor', \&Links::User::Editor::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/constants.pm b/site/slowtwitch.com/cgi-bin/articles/constants.pm new file mode 100644 index 0000000..1965796 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/constants.pm @@ -0,0 +1,143 @@ +# ================================================================== +# Gossamer Threads Module Library - http://gossamer-threads.com/ +# +# constants +# Author: Jason Rhinelander +# CVS Info : 087,071,086,086,085 +# $Id: constants.pm,v 1.9 2004/01/13 01:35:15 jagerman Exp $ +# +# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved. +# ================================================================== +# +# Description: +# Lightweight version of the standard constant.pm that allows you +# to declare multiple scalar constants in a single compile-time +# command. Like constant.pm, these scalar constants are optimized +# during Perl's compilation stage. +# Unlike constant.pm, this does not allow you to declare list +# constants. + +package constants; + + +use strict; +use Carp; +use vars qw($VERSION); + +$VERSION = '1.00'; + +#======================================================================= + +# Some of this stuff didn't work in version 5.003, alas. +require 5.003_96; + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + @_ or return; # Ignore 'use constant;' + my %constants = @_; + my $pkg = caller; + { + no strict 'refs'; + for my $name (keys %constants) { + croak qq{Can't define "$name" as constant} . + qq{ (name contains invalid characters or is empty)} + unless $name =~ /^[^\W_0-9]\w*$/; + my $scalar = $constants{$name}; + *{"${pkg}::$name"} = sub () { $scalar }; + } + } + +} + +1; + +__END__ + +=head1 NAME + +constants - Perl pragma to declare multiple scalar constants at once + +=head1 SYNOPSIS + + use constants BUFFER_SIZE => 4096, + ONE_YEAR => 365.2425 * 24 * 60 * 60, + PI => 4 * atan2 1, 1, + DEBUGGING => 0, + ORACLE => 'oracle@cs.indiana.edu', + USERNAME => scalar getpwuid($<); + + sub deg2rad { PI * $_[0] / 180 } + + print "This line does nothing" unless DEBUGGING; + + # references can be declared constants + use constants CHASH => { foo => 42 }, + CARRAY => [ 1,2,3,4 ], + CPSEUDOHASH => [ { foo => 1}, 42 ], + CCODE => sub { "bite $_[0]\n" }; + + print CHASH->{foo}; + print CARRAY->[$i]; + print CPSEUDOHASH->{foo}; + print CCODE->("me"); + print CHASH->[10]; # compile-time error + +=head1 DESCRIPTION + +This will declare a symbol to be a constant with the given scalar +value. This module mimics constant.pm in every way, except that it +allows multiple scalar constants to be created simultaneously. To +create constant list values you should use constant. + +See L for details about how constants work. + +=head1 NOTES + +The value or values are evaluated in a list context, so you should +override this if needed with C as shown above. + +=head1 TECHNICAL NOTE + +In the current implementation, scalar constants are actually +inlinable subroutines. As of version 5.004 of Perl, the appropriate +scalar constant is inserted directly in place of some subroutine +calls, thereby saving the overhead of a subroutine call. See +L for details about how and when this +happens. + +=head1 BUGS + +In the current version of Perl, list constants are not inlined +and some symbols may be redefined without generating a warning. + +It is not possible to have a subroutine or keyword with the same +name as a constant. This is probably a Good Thing. + +Unlike constants in some languages, these cannot be overridden +on the command line or via environment variables. + +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +For example, you can't say C<$hash{CONSTANT}> because C will +be interpreted as a string. Use C<$hash{CONSTANT()}> or +C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from +kicking in. Similarly, since the C<=E> operator quotes a bareword +immediately to its left you have to say C 'value'> +instead of C 'value'>. + +=head1 AUTHOR + +constant.pm: Tom Phoenix, EFE, with help from +many other folks. + +constants.pm: Jason Rhinelander, Gossamer Threads Inc. + +=cut diff --git a/site/slowtwitch.com/cgi-bin/articles/facebook.cgi b/site/slowtwitch.com/cgi-bin/articles/facebook.cgi new file mode 100755 index 0000000..71320a5 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/facebook.cgi @@ -0,0 +1,29 @@ +#!/usr/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,070,082,089,090 +# +# Copyright (c) 2001 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 '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$IN $CFG/; +use Plugins::Auth_Facebook; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +main(); + +sub main { + Plugins::Auth_Facebook::user_auth(); +} + + diff --git a/site/slowtwitch.com/cgi-bin/articles/feature.cgi b/site/slowtwitch.com/cgi-bin/articles/feature.cgi new file mode 100755 index 0000000..b8944a2 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/feature.cgi @@ -0,0 +1,52 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: jump.cgi,v 1.32 2005/03/30 09:20:49 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG $DB $IN $USER $CFG/; +use Links::User::Page; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($USER->{Status} eq 'Administrator') { + print $IN->header; + my $error = _update() if $IN->param('update'); + print Links::user_page('featured_links.html', { error => $error, message => $error ? "" : "Featured links are updated" }); +} +else { + print $IN->redirect('/'); +} + +sub _update { + my $cgi = $IN->get_hash(); + my @articles = map $cgi->{"article_$_"}, grep { $cgi->{"article_$_"} } 1..4; + my @photos = map $cgi->{"photo_$_"}, grep { $cgi->{"photo_$_"} } 1..2; + + return "All featured links are required" if scalar @articles < 4 or scalar @photos < 2; + + my $tab = $DB->table('Links'); + my $articles = $tab->count({ ID => \@articles, isValidated => 'Yes' }); + return "All 4 featured articles are required and not duplicate" if scalar $articles < 4; + + my $photos = $tab->count({ ID => \@photos, isValidated => 'Yes' }); + return "All 2 featured photos/videos are required and not duplicate" if scalar $photos < 2; + + $CFG->{featured_articles} = \@articles; + $CFG->{featured_photos} = \@photos; + $CFG->save; + return; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/jump.cgi b/site/slowtwitch.com/cgi-bin/articles/jump.cgi new file mode 100755 index 0000000..10b008c --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/jump.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: jump.cgi,v 1.32 2005/03/30 09:20:49 brewt 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG $IN/; +use Links::User::Jump; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_jump', \&Links::User::Jump::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/modify.cgi b/site/slowtwitch.com/cgi-bin/articles/modify.cgi new file mode 100755 index 0000000..86b4c6b --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/modify.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: modify.cgi,v 1.41 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Modify; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_modify', \&Links::User::Modify::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/page.cgi b/site/slowtwitch.com/cgi-bin/articles/page.cgi new file mode 100755 index 0000000..30b6edb --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/page.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: page.cgi,v 1.39 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Page; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_page', \&Links::User::Page::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/poll.cgi b/site/slowtwitch.com/cgi-bin/articles/poll.cgi new file mode 100755 index 0000000..aef235d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/poll.cgi @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use strict; +use lib "/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin"; +use GForum qw/$PLG $IN $CFG/; +use Poll; + +GForum::init("/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin"); + +$IN->param('call_from', "glinks"); +$IN->param('poll_id', "home") unless $IN->param('poll_id'); +Poll::handle(); diff --git a/site/slowtwitch.com/cgi-bin/articles/post_media.cgi b/site/slowtwitch.com/cgi-bin/articles/post_media.cgi new file mode 100755 index 0000000..439daf0 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/post_media.cgi @@ -0,0 +1,30 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: add.cgi,v 1.51 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG $IN/; +use Links::User::Add; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +main(); + +sub main { + use Plugins::SocialMedia; + Plugins::SocialMedia::publish_it(); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/postback.cgi b/site/slowtwitch.com/cgi-bin/articles/postback.cgi new file mode 100755 index 0000000..446a700 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/postback.cgi @@ -0,0 +1,62 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: postback.cgi,v 1.6 2005/03/05 01:29:08 brewt 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. +# ================================================================== +# +# This file (postback.cgi) is meant for handling postback for "remote" payment +# methods such as PayPal or WorldPay. Normal users should not reach this page, +# as this typically produces a blank (or nearly blank) page. No sort of user +# authentication is performed, and no user-based functionality is provided. +# Additionally, if no postback is found, or an error occurs, an ordinary die +# (producing a 500 Internal Server Error) is performed - payment providers +# often recognize this and will post the request again after a certain amount +# of time. + +# Pragmas +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; + +# Internal modules +use Links qw/$CFG $IN/; +use Links::Payment; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +$| = 1; + +# Start +main(); + +sub main { +# ----------------------------------------------------------------------------- +# Unlike the other .cgi's, we don't perform the various checks (such as the +# enabled/disabled check) because we ought to receive a posted payment even if +# the site has been disabled for some reason. + + # Check for payment postbacks + if ($CFG->{payment}->{enabled} and $CFG->{payment}->{postback} and @{$CFG->{payment}->{postback}}) { + for my $postback (@{$CFG->{payment}->{postback}}) { + next unless exists $CFG->{payment}->{$postback->{type}}->{methods}->{$postback->{method}} + and exists $CFG->{payment}->{$postback->{type}}->{used}->{$postback->{method}}; + my $var = $postback->{var}; + if (my $val = $IN->param($var)) { + if (!$postback->{var_regex} or $val =~ /$postback->{var_regex}/) { + if (Links::Payment->postback($postback)) { + return; + } + } + } + } + } + Links::Payment->invalid_postback; + die 'postback.cgi called, but no payment method postback could be identified.'; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/rate.cgi b/site/slowtwitch.com/cgi-bin/articles/rate.cgi new file mode 100755 index 0000000..0a05eea --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/rate.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: rate.cgi,v 1.30 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Rate; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_rate', \&Links::User::Rate::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/review.cgi b/site/slowtwitch.com/cgi-bin/articles/review.cgi new file mode 100755 index 0000000..d43d492 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/review.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: review.cgi,v 1.7 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Review; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_review', \&Links::User::Review::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/search.cgi b/site/slowtwitch.com/cgi-bin/articles/search.cgi new file mode 100755 index 0000000..979dbd4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/search.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: search.cgi,v 1.56 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Search; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_search', \&Links::User::Search::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/showpicture.cgi b/site/slowtwitch.com/cgi-bin/articles/showpicture.cgi new file mode 100755 index 0000000..6241188 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/showpicture.cgi @@ -0,0 +1,117 @@ +#!/usr/bin/perl +# ================================================================== +# Links SQL - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,070,087,092,085 +# Revision : $Id: showpicture.cgi,v 1.6 2006/12/29 15:37:20 aki 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. +# ================================================================== + + use strict; + use lib 'admin'; + use Links qw/$DB $IN $USER $CFG/; + use Links::Plugins; + + Links::init('admin'); + Links::init_user(); + + local $SIG{__DIE__} = \&Links::fatal; + + + main(); + +sub main { +# ------------------------------------------------------------------- +# display an html page for a picture frame +# + + my $tbl = $DB->table('Links'); + my $id = $IN->param('ID'); + my $rec = $tbl->get( $id ) || {}; + my $col = $IN->param('v'); + +# go through and find out what columsn have images + my $conf = Links::Plugins::get_plugin_user_cfg( 'SlideShow' ); + my @image_cols = grep $_, map { s,^(\s*),,; s,(\s*)$,,; $_ } split /,/, $conf->{seq_image_cols}; + + $col ||= $image_cols[ int( $IN->param( 'index' ) || 0 ) || 0]; + $col ||= $image_cols[0]; + + my $cached = eval $rec->{SlideShowCache}; + my $changed = 1; + my ( $linksdb, $linkscols, %image_lookup ); + + require Plugins::SlideShow; + my $paths = Plugins::SlideShow::generate_paths( $id, $rec ); + @$rec{ keys %$paths } = values %$paths; + +# find out which columns have files (assume images) populated +# create +# - @images order array with column names +# - %images hash with the index lookup + my ( @images, %images, $index ); + foreach my $colname ( @image_cols ) { + $rec->{$colname} or next; + push @images, $colname; + $images{$colname} = $index++; + } + +# find out where we are in the list + my ( $Image_Previous, $Image_Next, $Image_First, $Image_Last, + $Image_Count, $Image_Tool, $Image_Current ); + $Image_Count = scalar( @images ); + $index = $images{ $col }; # convert from column name to index # + +# get the next and previous + ( $index > 0 ) and $Image_Previous = $images[$index-1]; + ( $index < $Image_Count ) and $Image_Next = $images[$index+1]; + +# get the first and last + $Image_Current = $index + 1; + $index and $Image_First = $images[0]; + $index+1 < $Image_Count and $Image_Last = $images[$Image_Count-1]; + +# for the toolbar + $index = 1; + foreach my $colname ( @images ) { + push @{$Image_Tool}, { + Image_Colname => $colname, + Image_Index => $index++, + Image_Selected => ( $colname eq $col ? 1 : 0 ), + }; + } + + + print $IN->header(); + print Links::user_page( + 'pictureframe.html', + { + %{$USER || {} }, + %{$IN->get_hash}, + %$rec, + %{$image_lookup{$col}||{}}, + Image_Previous => $Image_Previous, + Image_First => $Image_First, + Image_Last => $Image_Last, + Image_Next => $Image_Next, + Image_Count => $Image_Count, + Image_Current => $Image_Current, + Image_Description => $rec->{$col."_description"}, + Image_Tool => $Image_Tool, + image_url_path => sub { + my $col = join( "_", @_ ) or return; + my $tags = GT::Template->tags; + return $tags->{$col.'_path'}; + } + } + ); + +} + + + diff --git a/site/slowtwitch.com/cgi-bin/articles/subscribe.cgi b/site/slowtwitch.com/cgi-bin/articles/subscribe.cgi new file mode 100755 index 0000000..e9849cf --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/subscribe.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: subscribe.cgi,v 1.29 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::Newsletter; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_subscribe', \&Links::Newsletter::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/test.cgi b/site/slowtwitch.com/cgi-bin/articles/test.cgi new file mode 100755 index 0000000..f616a90 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/test.cgi @@ -0,0 +1,59 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,068,085,094,083 +# Revision : $Id: page.cgi,v 1.39 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use JSON::XS; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); + +my $data = [ + { + "id" => "1", + "name" => "Big Ben", + "latitude" => "51.500600000000", + "longitude" => "-0.124610000000", + city => 'Vancouver' + }, + { + "id" => "4", + "name" => "Hadrian's Wall", + "latitude" => "55.024453000000", + "longitude" => "2.142310000000", + city => 'Vancouver' + }, + { + "id" => "2", + "name" => "Stonehenge", + "latitude" => "51.178850000000", + "longitude" => "-1.826446000000", + city => 'Calgary' + }, + { + "id" => "3", + "name" => "White Cliffs of Dover", + "latitude" => "51.132020000000", + "longitude" => "1.334070000000", + city => 'Toronto' + } +]; + +print $IN->header; +print "FOO"; +#use CGI; +#my $in = new CGI; +#print $in->header({ 'content-type' => 'application/json', 'no-cache' => 1 }); +#my $city = lc ( $in->param('city') || 'All' ); +#print encode_json($data); diff --git a/site/slowtwitch.com/cgi-bin/articles/threads.cgi b/site/slowtwitch.com/cgi-bin/articles/threads.cgi new file mode 100755 index 0000000..d2ed2e4 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/threads.cgi @@ -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!!; + } + print qq!
          $html
          !; +} diff --git a/site/slowtwitch.com/cgi-bin/articles/ticker/admin/.htaccess b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/.htaccess new file mode 100644 index 0000000..9578e21 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/.htaccess @@ -0,0 +1,6 @@ +AuthUserFile /var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/.htpasswd +AuthGroupFile /dev/null +AuthType Basic +AuthName Protected + +require valid-user diff --git a/site/slowtwitch.com/cgi-bin/articles/ticker/admin/admin.cgi b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/admin.cgi new file mode 100755 index 0000000..20bbffe --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/admin.cgi @@ -0,0 +1,163 @@ +#!/usr/local/bin/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/site/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw(:objects); +use Ticker; +use Error qw(:try); + +Links::init('/var/home/slowtwitch/site/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +use constant { + STATE_NORMAL => 0, + STATE_UPDATE => 1, + STATE_REDIRECT => 2, + ADMIN_URL => "https://www.slowtwitch.com/cgi-bin/articles/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{Ticker Admin}; + + # 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 "

          " . $s{error} . "

          "; + } + + # 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{

          } . $s{title} . qq{

          +
          + + +
          + +
          + +
          +
          + }; + + # provide a way to get back to the create interface: + if($s{action} =~ /update/) { + print qq{Create a ticker instead.}; + } + + # Now print the entire list of all tickers. + print qq{

          Current tickers:

          }; + + + # 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 ""; + print ""; + foreach my $k (@{$s{data}}) { + my $id = $k->{ticker_id}; + my $msg = $k->{ticker_text}; + my $link = $k->{ticker_link}; + print qq{"; + } + print "
          IDMessageLink
          $id + Delete + Update} . + $msg . "" . + qq{} . + $link . "
          "; + } + print qq{}; +} + diff --git a/site/slowtwitch.com/cgi-bin/articles/ticker/admin/sql.cgi b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/sql.cgi new file mode 100755 index 0000000..92a5674 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/ticker/admin/sql.cgi @@ -0,0 +1,11 @@ +#!/bin/env perl + +use strict; +use warnings; +use lib '/home/slowtwitch/site/slowtwitch.com/cgi-bin/articles/admin'; +use Ticker; + +Links::init('/var/home/slowtwitch/site/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_admin(); + +Ticker::create_table(); diff --git a/site/slowtwitch.com/cgi-bin/articles/ticker/coupons.cgi b/site/slowtwitch.com/cgi-bin/articles/ticker/coupons.cgi new file mode 100755 index 0000000..785c405 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/ticker/coupons.cgi @@ -0,0 +1,20 @@ +#!/usr/local/bin/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/slowtwitch.com/cgi-bin/articles/admin'; +use GT::Template; +use Links qw(:objects); +use Ticker; + +Links::init('/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +print $IN->header(); +print Links->user_page('include_ticker_coupons.html'); \ No newline at end of file diff --git a/site/slowtwitch.com/cgi-bin/articles/ticker/ticker.cgi b/site/slowtwitch.com/cgi-bin/articles/ticker/ticker.cgi new file mode 100755 index 0000000..954fb44 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/ticker/ticker.cgi @@ -0,0 +1,17 @@ +#!/usr/local/bin/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/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw(:objects); +Links::init('/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +use Ticker; + +print $IN->header(-type => "text/xml"); +print Ticker::read_tickers_xml(); diff --git a/site/slowtwitch.com/cgi-bin/articles/treecats.cgi b/site/slowtwitch.com/cgi-bin/articles/treecats.cgi new file mode 100755 index 0000000..5ba11ae --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/treecats.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: treecats.cgi,v 1.6 2006/08/11 20:38:43 brewt 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 '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Treecats; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_treecats', \&Links::User::Treecats::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/articles/user.cgi b/site/slowtwitch.com/cgi-bin/articles/user.cgi new file mode 100755 index 0000000..14c3e67 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/articles/user.cgi @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl +# ================================================================== +# Gossamer Links - enhanced directory management system +# +# Website : http://gossamer-threads.com/ +# Support : http://gossamer-threads.com/scripts/support/ +# CVS Info : 087,071,086,086,085 +# Revision : $Id: user.cgi,v 1.41 2005/03/22 08:18:05 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. +# ================================================================== + +use strict; +use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'; +use Links qw/$PLG/; +use Links::User::Login; + +local $SIG{__DIE__} = \&Links::fatal; + +Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'); +Links::init_user(); + +if ($PLG->dispatch('check_request', \&Links::check_request)) { + $PLG->dispatch('handle_login', \&Links::User::Login::handle); +} diff --git a/site/slowtwitch.com/cgi-bin/cgi-lib.pl b/site/slowtwitch.com/cgi-bin/cgi-lib.pl new file mode 100755 index 0000000..9ab0405 --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/cgi-lib.pl @@ -0,0 +1,456 @@ +# Perl Routines to Manipulate CGI input +# Steven E. Brenner / cgi-lib@pobox.com +# $Id: cgi-lib.pl,v 2.12 1996/06/19 13:46:01 brenner Exp $ +# +# Copyright (c) 1996 Steven E. Brenner +# Unpublished work. +# Permission granted to use and modify this library so long as the +# copyright above is maintained, modifications are documented, and +# credit is given for any use of the library. +# +# Thanks are due to many people for reporting bugs and suggestions +# especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen, +# Andrew Dalke, Mark-Jason Dominus, Dave Dittrich, Jason Mathews + +# For more information, see: +# http://www.bio.cam.ac.uk/cgi-lib/ + +$cgi_lib'version = sprintf("%d.%02d", q$Revision: 2.12 $ =~ /(\d+)\.(\d+)/); + + +# Parameters affecting cgi-lib behavior +# User-configurable parameters affecting file upload. +$cgi_lib'maxdata = 131072; # maximum bytes to accept via POST - 2^17 +$cgi_lib'writefiles = 0; # directory to which to write files, or + # 0 if files should not be written +$cgi_lib'filepre = "cgi-lib"; # Prefix of file names, in directory above + +# Do not change the following parameters unless you have special reasons +$cgi_lib'bufsize = 8192; # default buffer size when reading multipart +$cgi_lib'maxbound = 100; # maximum boundary length to be encounterd +$cgi_lib'headerout = 0; # indicates whether the header has been printed + + +# ReadParse +# Reads in GET or POST data, converts it to unescaped text, and puts +# key/value pairs in %in, using "\0" to separate multiple selections + +# Returns >0 if there was input, 0 if there was no input +# undef indicates some failure. + +# Now that cgi scripts can be put in the normal file space, it is useful +# to combine both the form and the script in one place. If no parameters +# are given (i.e., ReadParse returns FALSE), then a form could be output. + +# If a reference to a hash is given, then the data will be stored in that +# hash, but the data from $in and @in will become inaccessable. +# If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse, +# information is stored there, rather than in $in, @in, and %in. +# Second, third, and fourth parameters fill associative arrays analagous to +# %in with data relevant to file uploads. + +# If no method is given, the script will process both command-line arguments +# of the form: name=value and any text that is in $ENV{'QUERY_STRING'} +# This is intended to aid debugging and may be changed in future releases + +sub ReadParse { + local (*in) = shift if @_; # CGI input + local (*incfn, # Client's filename (may not be provided) + *inct, # Client's content-type (may not be provided) + *insfn) = @_; # Server's filename (for spooled files) + local ($len, $type, $meth, $errflag, $cmdflag, $perlwarn, $got); + + # Disable warnings as this code deliberately uses local and environment + # variables which are preset to undef (i.e., not explicitly initialized) + $perlwarn = $^W; + $^W = 0; + + binmode(STDIN); # we need these for DOS-based systems + binmode(STDOUT); # and they shouldn't hurt anything else + binmode(STDERR); + + # Get several useful env variables + $type = $ENV{'CONTENT_TYPE'}; + $len = $ENV{'CONTENT_LENGTH'}; + $meth = $ENV{'REQUEST_METHOD'}; + + if ($len > $cgi_lib'maxdata) { #' + &CgiDie("cgi-lib.pl: Request to receive too much data: $len bytes\n"); + } + + if (!defined $meth || $meth eq '' || $meth eq 'GET' || + $type eq 'application/x-www-form-urlencoded') { + local ($key, $val, $i); + + # Read in text + if (!defined $meth || $meth eq '') { + $in = $ENV{'QUERY_STRING'}; + $cmdflag = 1; # also use command-line options + } elsif($meth eq 'GET' || $meth eq 'HEAD') { + $in = $ENV{'QUERY_STRING'}; + } elsif ($meth eq 'POST') { + if (($got = read(STDIN, $in, $len) != $len)) + {$errflag="Short Read: wanted $len, got $got\n"}; + } else { + &CgiDie("cgi-lib.pl: Unknown request method: $meth\n"); + } + + @in = split(/[&;]/,$in); + push(@in, @ARGV) if $cmdflag; # add command-line parameters + + foreach $i (0 .. $#in) { + # Convert plus to space + $in[$i] =~ s/\+/ /g; + + # Split into key and value. + ($key, $val) = split(/=/,$in[$i],2); # splits on the first =. + + # Convert %XX from hex numbers to alphanumeric + $key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; + $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; + + # Associate key and value + $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator + $in{$key} .= $val; + } + + } elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) { + # for efficiency, compile multipart code only if needed +$errflag = !(eval <<'END_MULTIPART'); + + local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen); + local ($bpos, $lpos, $left, $amt, $fn, $ser); + local ($bufsize, $maxbound, $writefiles) = + ($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles); + + + # The following lines exist solely to eliminate spurious warning messages + $buf = ''; + + ($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary + ($boundary) = $type =~ /boundary=(\S+)/ unless $boundary; + &CgiDie ("Boundary not provided: probably a bug in your server") + unless $boundary; + $boundary = "--" . $boundary; + $blen = length ($boundary); + + if ($ENV{'REQUEST_METHOD'} ne 'POST') { + &CgiDie("Invalid request method for multipart/form-data: $meth\n"); + } + + if ($writefiles) { + local($me); + stat ($writefiles); + $writefiles = "/tmp" unless -d _ && -r _ && -w _; + # ($me) = $0 =~ m#([^/]*)$#; + $writefiles .= "/$cgi_lib'filepre"; + } + + # read in the data and split into parts: + # put headers in @in and data in %in + # General algorithm: + # There are two dividers: the border and the '\r\n\r\n' between + # header and body. Iterate between searching for these + # Retain a buffer of size(bufsize+maxbound); the latter part is + # to ensure that dividers don't get lost by wrapping between two bufs + # Look for a divider in the current batch. If not found, then + # save all of bufsize, move the maxbound extra buffer to the front of + # the buffer, and read in a new bufsize bytes. If a divider is found, + # save everything up to the divider. Then empty the buffer of everything + # up to the end of the divider. Refill buffer to bufsize+maxbound + # Note slightly odd organization. Code before BODY: really goes with + # code following HEAD:, but is put first to 'pre-fill' buffers. BODY: + # is placed before HEAD: because we first need to discard any 'preface,' + # which would be analagous to a body without a preceeding head. + + $left = $len; + PART: # find each part of the multi-part while reading data + while (1) { + die $@ if $errflag; + + $amt = ($left > $bufsize+$maxbound-length($buf) + ? $bufsize+$maxbound-length($buf): $left); + $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); + die "Short Read: wanted $amt, got $got\n" if $errflag; + $left -= $amt; + + $in{$name} .= "\0" if defined $in{$name}; + $in{$name} .= $fn if $fn; + + $name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted + if (defined $1) { + $insfn{$1} .= "\0" if defined $insfn{$1}; + $insfn{$1} .= $fn if $fn; + } + + BODY: + while (($bpos = index($buf, $boundary)) == -1) { + die $@ if $errflag; + if ($name) { # if no $name, then it's the prologue -- discard + if ($fn) { print FILE substr($buf, 0, $bufsize); } + else { $in{$name} .= substr($buf, 0, $bufsize); } + } + $buf = substr($buf, $bufsize); + $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); + $errflag = (($got = read(STDIN, $buf, $amt, $maxbound)) != $amt); + die "Short Read: wanted $amt, got $got\n" if $errflag; + $left -= $amt; + } + if (defined $name) { # if no $name, then it's the prologue -- discard + if ($fn) { print FILE substr($buf, 0, $bpos-2); } + else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n + } + close (FILE); + last PART if substr($buf, $bpos + $blen, 4) eq "--\r\n"; + substr($buf, 0, $bpos+$blen+2) = ''; + $amt = ($left > $bufsize+$maxbound-length($buf) + ? $bufsize+$maxbound-length($buf) : $left); + $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); + die "Short Read: wanted $amt, got $got\n" if $errflag; + $left -= $amt; + + + undef $head; undef $fn; + HEAD: + while (($lpos = index($buf, "\r\n\r\n")) == -1) { + die $@ if $errflag; + $head .= substr($buf, 0, $bufsize); + $buf = substr($buf, $bufsize); + $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); + $errflag = (($got = read(STDIN, $buf, $amt, $maxbound)) != $amt); + die "Short Read: wanted $amt, got $got\n" if $errflag; + $left -= $amt; + } + $head .= substr($buf, 0, $lpos+2); + push (@in, $head); + @heads = split("\r\n", $head); + ($cd) = grep (/^\s*Content-Disposition:/i, @heads); + ($ct) = grep (/^\s*Content-Type:/i, @heads); + + ($name) = $cd =~ /\bname="([^"]+)"/i; #"; + ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name; + + ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str + ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname; + $incfn{$name} .= (defined $in{$name} ? "\0" : "") . $fname; + + ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #"; + ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype; + $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype; + + if ($writefiles && defined $fname) { + $ser++; + $fn = $writefiles . ".$$.$ser"; + open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n"); + binmode (FILE); # write files accurately + } + substr($buf, 0, $lpos+4) = ''; + undef $fname; + undef $ctype; + } + +1; +END_MULTIPART + if ($errflag) { + local ($errmsg, $value); + $errmsg = $@ || $errflag; + foreach $value (values %insfn) { + unlink(split("\0",$value)); + } + &CgiDie($errmsg); + } else { + # everything's ok. + } + } else { + &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n"); + } + + # no-ops to avoid warnings + $insfn = $insfn; + $incfn = $incfn; + $inct = $inct; + + $^W = $perlwarn; + + return ($errflag ? undef : scalar(@in)); +} + + +# PrintHeader +# Returns the magic line which tells WWW that we're an HTML document + +sub PrintHeader { + return "Content-type: text/html\n\n"; +} + + +# HtmlTop +# Returns the of a document and the beginning of the body +# with the title and a body

          header as specified by the parameter + +sub HtmlTop +{ + local ($title) = @_; + + return < + +$title + + +

          $title

          +END_OF_TEXT +} + + +# HtmlBot +# Returns the , codes for the bottom of every HTML page + +sub HtmlBot +{ + return "\n\n"; +} + + +# SplitParam +# Splits a multi-valued parameter into a list of the constituent parameters + +sub SplitParam +{ + local ($param) = @_; + local (@params) = split ("\0", $param); + return (wantarray ? @params : $params[0]); +} + + +# MethGet +# Return true if this cgi call was using the GET request, false otherwise + +sub MethGet { + return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET"); +} + + +# MethPost +# Return true if this cgi call was using the POST request, false otherwise + +sub MethPost { + return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST"); +} + + +# MyBaseUrl +# Returns the base URL to the script (i.e., no extra path or query string) +sub MyBaseUrl { + local ($ret, $perlwarn); + $perlwarn = $^W; $^W = 0; + $ret = 'http://' . $ENV{'SERVER_NAME'} . + ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . + $ENV{'SCRIPT_NAME'}; + $^W = $perlwarn; + return $ret; +} + + +# MyFullUrl +# Returns the full URL to the script (i.e., with extra path or query string) +sub MyFullUrl { + local ($ret, $perlwarn); + $perlwarn = $^W; $^W = 0; + $ret = 'http://' . $ENV{'SERVER_NAME'} . + ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . + $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} . + (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : ''); + $^W = $perlwarn; + return $ret; +} + + +# MyURL +# Returns the base URL to the script (i.e., no extra path or query string) +# This is obsolete and will be removed in later versions +sub MyURL { + return &MyBaseUrl; +} + + +# CgiError +# Prints out an error message which which containes appropriate headers, +# markup, etcetera. +# Parameters: +# If no parameters, gives a generic error message +# Otherwise, the first parameter will be the title and the rest will +# be given as different paragraphs of the body + +sub CgiError { + local (@msg) = @_; + local ($i,$name); + + if (!@msg) { + $name = &MyFullUrl; + @msg = ("Error: script $name encountered fatal error\n"); + }; + + if (!$cgi_lib'headerout) { #') + print &PrintHeader; + print "\n\n$msg[0]\n\n\n"; + } + print "

          $msg[0]

          \n"; + foreach $i (1 .. $#msg) { + print "

          $msg[$i]

          \n"; + } + + $cgi_lib'headerout++; +} + + +# CgiDie +# Identical to CgiError, but also quits with the passed error message. + +sub CgiDie { + local (@msg) = @_; + &CgiError (@msg); + die @msg; +} + + +# PrintVariables +# Nicely formats variables. Three calling options: +# A non-null associative array - prints the items in that array +# A type-glob - prints the items in the associated assoc array +# nothing - defaults to use %in +# Typical use: &PrintVariables() + +sub PrintVariables { + local (*in) = @_ if @_ == 1; + local (%in) = @_ if @_ > 1; + local ($out, $key, $output); + + $output = "\n
          \n"; + foreach $key (sort keys(%in)) { + foreach (split("\0", $in{$key})) { + ($out = $_) =~ s/\n/
          \n/g; + $output .= "
          $key\n
          :$out:
          \n"; + } + } + $output .= "
          \n"; + + return $output; +} + +# PrintEnv +# Nicely formats all environment variables and returns HTML string +sub PrintEnv { + &PrintVariables(*ENV); +} + + +# The following lines exist only to avoid warning messages +$cgi_lib'writefiles = $cgi_lib'writefiles; +$cgi_lib'bufsize = $cgi_lib'bufsize ; +$cgi_lib'maxbound = $cgi_lib'maxbound; +$cgi_lib'version = $cgi_lib'version; +$cgi_lib'filepre = $cgi_lib'filepre; + +1; #return true + diff --git a/site/slowtwitch.com/cgi-bin/parse.pl b/site/slowtwitch.com/cgi-bin/parse.pl new file mode 100755 index 0000000..17b734d --- /dev/null +++ b/site/slowtwitch.com/cgi-bin/parse.pl @@ -0,0 +1,95 @@ +#!/usr/bin/perl + +################################################################################################ +#who: Kevin Palmer, KP Web Design +#what: perl script which searches a given file for a given string, highlights all matches of +# that string, and prints the highlighted text to the screen +#last edited: 10/25/01 +#why: Slowtwitch Search Engine +################################################################################################ + +# The CGI.pm module is by far the best CGI module for Perl +use CGI qw(:standard); + +print header(-expires=>"$expire"); + +my $client=new CGI(); + +$text = $client->url_param('text'); +$url = $client->url_param('url'); #file url +$my_url=$client->self_url(); + +$file = "/home/slowtwitch/slowtwitch.com/www" . substr($url,25); # relative file path from /cgi-bin (cut 'http://www.slowtwitch.com' from url) +$path = substr($url,0,rindex($url, '/')); #file path minus filename + +unless(-e "$file") { die "File does not exist: $file\n"; } +open(FILE,"<$file") or die "Cannot open $file.\n"; + +while() { + my $line="$_"; + + #replace HTML codes for non-enlish characters with english "equivalents" +# $line =~ s/\ä\;/a/gi; +# $line =~ s/\ü\;/u/gi; + + #if "unreadable EOL" character exists, split page at "EOLs" to yield "lines" + if ($line =~ /\r/) { + @lines = split(\r,$line); + foreach $x (@lines) { + + $x =~ s/$text/$&<\/span>/gi; #highlight search text + + ####edit relative image and file paths for correctness from cgi-bin/ + + ##edit image paths so image links work properly from cgi-bin/ + if ($x =~ m/src=\"\w\w\w\w/i) { #no path, just filename (assumes all filenames are at least 4 characters long) + if ($& ne "src=\"http") { #not an absolute link (assumes all absolute links are to outside domains) + my @parts = split(/\"/, $&); + $x =~ s/src=\"\w\w\w\w/$parts[0]\"$path\/$parts[1]/gi; + } + } + $x =~ s/src=\"\.\./src=\"$path\/\.\./gi; # parent path (relative link) + $x =~ s/src=\"\//src=\"$path\//gi; # absolute virtual path + + ##edit anchor paths so links work properly from cgi-bin/ + + $x =~ s/$&<\/span>/gi; #highlight search text + + ####edit relative image and file paths for correctness from cgi-bin/ + + ##edit image paths so image links work properly from cgi-bin/ + if ($line =~ m/src=\"\w\w\w\w/i) { #no path, just filename (assumes all filenames are at least 4 characters long) + if ($& ne "src=\"http") { #not an absolute link (assumes all absolute links are to outside domains) + my @parts = split(/\"/, $&); + $line =~ s/src=\"\w\w\w\w/$parts[0]\"$path\/$parts[1]/gi; + } + } + $line =~ s/src=\"\.\./src=\"$path\/\.\./gi; # parent path (relative link) + $line =~ s/src=\"\//src=\"$path\//gi; # absolute virtual path + + $line =~ s//) { + my $comment=$1; + $comment =~ s/\s//g; # strip all whitespace + + # COMMENT DISPATCH TABLE + + if($comment =~ /(.+)RESULTS(.+)/) { + # Ok, put the results here, formatted as + # requested. + my $sf=$1; # opening formatting + my $ef=$2; # ending formatting + for(Handle_Submission($cur)) { + print "$sf$_$ef$RET" + } + } #endif + } #endif +} #end Handle_Comment + +# Print a Spindex template page +# Syntax: Print_Page($cgi-process) +sub Print_Page { + my $cur=shift; + # Open the normal template + unless(-e "$templateFile") { die "File does not exist: $templateFile\n"; } + open(TEMPL,"<$templateFile") or die "Cannot open $templateFile.\n"; + + # Spit the expiration jazz to the browser to control + # content caching. NOTE: Usually ignored by IE. :( + print header(-expires=>"$expire"); + while() { + my $tline="$_"; + # Print the line to the browser, or else handle + # it as a comment + unless($tline =~ /"; + if ($mailprog || $recipientlist) { + $listing .= "$lines[2])"; } + else { $listing .= "E-Mail Unknown)"; } + push (@emails1,"$listing"); + unless ($lines[2]) { next; } + push (@emails2,""$lines[1]" <$lines[2]>"); +} + +sub emailmembers { + &ConfirmAdminPassword(1); + @bcclist = split(/\s/,$INPUT{'emails'}); + foreach $bcc (sort @bcclist) { + if ($bcc eq $lastbcc) { next; } + if (length($bcc)<3) { next; } + push (@bcc,$bcc); + $lastbcc = $bcc; + } + &SendMail($email_address,"groupmail"); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          E-Mail Sent\n", + "

          The message has been sent.\n"; + &LinkBack; + &Footer; +} + +sub ExpireEmailUpdate { + &ConfirmAdminPassword(1); + @recipientlist = split(/\s/,$INPUT{'emails'}); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          Recipient List Updated\n", + "

          The following accounts will receive update notices ", + "when the "ads_expire.pl" script is run:\n

          "; + open (LIST, ">$ADVadverts_dir/adexpirelist.txt"); + $lastrecipient = ""; + foreach $recipient (sort @recipientlist) { + if ($lastrecipient) { print "
          "; } + print "$recipient\n"; + print LIST "$recipient\n"; + $lastrecipient = $recipient; + } + close (LIST); + &LinkBack; + &Footer; +} + +sub reviewgroup { + $groupstatus = "$AccountName"; + unless (-s "$ADVadverts_dir/$AccountName.grp") { + if ($AllowUserEdit && $INPUT{'newuser'}) { + &UserEdit; + } + &Header("$text{'9000'}","$text{'9050'}"); + print "

          $text{'9051'} "; + print ""$AccountName" $text{'9052'}\n"; + &Footer; + } + open (DISPLAY, "<$ADVadverts_dir/$AccountName.grp"); + @adverts = ; + close (DISPLAY); + chomp (@adverts); + unless ($cryptword) { + unless ($INPUT{'password'} eq $adverts[0]) { + &ConfirmAdminPassword(2); + } + } + &Header("$text{'1000'}","$text{'1001'}"); + print "

          $text{'2000'} "; + print "$AccountName $text{'2001'}\n"; + foreach $advert (@adverts) { + $name = $advert; + $subdir = substr($advert,0,1); + $subdir .= "/$advert"; + next unless (-s "$ADVadverts_dir/$subdir/$advert.txt"); + open (DISPLAY, "<$ADVadverts_dir/$subdir/$advert.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + ($pass,$username,$email,$comments) = @lines; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$advert.txt"); + @lines = ; + close (DISPLAY); + chomp (@lines); + ($max,$shown,$visits,$url,$image,$height,$width, + $alt,$nada,$text,$start,$weight,$zone, + $border,$target,$raw,$displayratio,$nada,$nada, + $displayzone,$clicksfrom) = @lines; + ($max,$maxtype) = split(/\|/, $max); + unless ($maxtype) { $maxtype = "E"; } + ($text,$texttype) = split(/\|/, $text); + unless ($texttype) { $texttype = "B"; } + ($displayratio,$displaycount) = split(/\|/, $displayratio); + ($clicksfrom,$clicksratio) = split(/\|/, $clicksfrom); + if ($maxtype eq "N") { $max = 0; } + if ((($maxtype eq "E") || ($maxtype eq "N")) && ($displayratio > 0)) { + $max = $max+int($displaycount/$displayratio); + } + if ((($maxtype eq "E") || ($maxtype eq "N")) && ($clicksratio > 0)) { + $max = $max+($clicksfrom*$clicksratio); + } + if ($max == 0) { $max = "0"; } + $TotalShown += $shown; + $TotalVisits += $visits; + print "


          \n"; + &reviewadvert; + } + print "


          $text{'2002'}", + "\n", + "

          \n", + "", + "", + "", + "", + "\n"; + if (($TotalShown == 0) || ($TotalVisits == 0)) { + $perc = "$text{'2020'}"; + $ratio = "$text{'2020'}"; + } + else { + $perc = ((100*($TotalVisits/$TotalShown))+.05001); + $ratio = (($TotalShown/$TotalVisits)+.5001); + } + unless ($perc eq "$text{'2020'}") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + unless ($ratio eq "$text{'2020'}") { + $ratio =~ s/(\d+)\.\d.*/$1/; + $ratio = $ratio.":1"; + } + print ""; + print ""; + print ""; + print "\n"; + print "
          $text{'2015'}

          $text{'2017'}

          $text{'2018'}

          $text{'2019'}

          ",&commas($TotalShown),"",&commas($TotalVisits),"$perc$ratio
          \n"; + &Footer("Group: $AccountName"); +} + +sub reviewone { + unless ($INPUT{'password'}) { + &Header("$text{'9000'}","$text{'9020'}"); + print "

          $text{'9021'}\n"; + &Footer; + } + $AccountName = $INPUT{'reviewone'}; + &CheckName; + if ($INPUT{'admincheck'}) { + &ConfirmAdminPassword(2); + } + unless (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + &reviewgroup; + } + $name = $AccountName; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + ($pass,$username,$email,$comments) = @lines; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.txt"); + @lines = ; + close (DISPLAY); + chomp (@lines); + ($max,$shown,$visits,$url,$image,$height,$width, + $alt,$nada,$text,$start,$weight,$zone, + $border,$target,$raw,$displayratio,$nada,$nada, + $displayzone,$clicksfrom) = @lines; + ($max,$maxtype) = split(/\|/, $max); + unless ($maxtype) { $maxtype = "E"; } + ($text,$texttype) = split(/\|/, $text); + unless ($texttype) { $texttype = "B"; } + ($displayratio,$displaycount) = split(/\|/, $displayratio); + ($clicksfrom,$clicksratio) = split(/\|/, $clicksfrom); + if ($maxtype eq "N") { $max = 0; } + if ((($maxtype eq "E") || ($maxtype eq "N")) && ($displayratio > 0)) { + $max = $max+int($displaycount/$displayratio); + } + if ((($maxtype eq "E") || ($maxtype eq "N")) && ($clicksratio > 0)) { + $max = $max+($clicksfrom*$clicksratio); + } + if ($max == 0) { $max = "0"; } + unless ($cryptword) { + unless ($INPUT{'password'} eq $pass) { + &ConfirmAdminPassword(2); + } + } + &Header("$text{'1000'}","$text{'1001'}"); + &reviewadvert; + if ($cryptword) { + if ($comments) { print "

          Comments: $comments\n"; } + &LinkBack; + } + else { + print "

          \n"; + print "
          \n"; + print "\n"; + print "
          \n"; + } + &Footer("Account: $AccountName"); +} + +sub reviewadvert { + $expired = 0; + print "

          $text{'2005'} "; + print "$name $text{'2006'}\n"; + open (COUNT, "$ADVadverts_dir/adnew.txt"); + @lines = ; + close (COUNT); + chomp (@lines); + foreach $line (@lines) { + if ($line eq $name) { + print "

          $text{'2007'}"; + last; + } + } + print "

          \n"; + print "

          \n"; + print ""; + print ""; + if ($displayratio || $displaycount || $clicksratio || $clicksfrom) { + print ""; + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print ""; + print ""; + print ""; + } + print "\n"; + print ""; + if ($start) { + ($sec,$min,$hour,$mday,$mon,$year, + $wday,$yday,$isdst) = localtime($start+($ADVHourOffset*3600)); + $year += 1900; + print ""; + $runtime = $time - $start + 1; + } + else { print ""; } + if (($displaycount == 0) || ($clicksfrom == 0)) { + $foreignperc = "$text{'2020'}"; + $foreignratio = "$text{'2020'}"; + } + else { + $foreignperc = ((100*($clicksfrom/$displaycount))+.05001); + $foreignratio = (($displaycount/$clicksfrom)+.5001); + } + unless ($foreignperc eq "$text{'2020'}") { + $foreignperc =~ s/(\d+\.\d).*/$1/; + $foreignperc = $foreignperc."%"; + } + unless ($foreignratio eq "$text{'2020'}") { + $foreignratio =~ s/(\d+)\.\d.*/$1/; + $foreignratio = $foreignratio.":1"; + } + print ""; + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print ""; + print ""; + print ""; + } + print "\n"; + print "
          $text{'2011'}

          $text{'2040'}"; + print "

          $text{'2041'}"; + print "

          $text{'2018'}

          $text{'2019'}

          $mday $months[$mon] $year",&commas($displaycount),"",&commas($clicksfrom),"$foreignperc$foreignratio
          \n"; + print "

          \n"; + print ""; + } + else { + print ""; + } + if ($image || $raw || $shown || $visits) { + print ""; + print ""; + print ""; + print ""; + print ""; + } + print "\n"; + if (($shown == 0) || ($visits == 0)) { + $perc = "$text{'2020'}"; + $ratio = "$text{'2020'}"; + } + else { + $perc = ((100*($visits/$shown))+.05001); + $ratio = (($shown/$visits)+.5001); + } + unless ($perc eq "$text{'2020'}") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + unless ($ratio eq "$text{'2020'}") { + $ratio =~ s/(\d+)\.\d.*/$1/; + $ratio = $ratio.":1"; + } + print ""; + $runtime = 0; + if ($start) { + ($sec,$min,$hour,$mday,$mon,$year, + $wday,$yday,$isdst) = localtime($start+($ADVHourOffset*3600)); + $year += 1900; + unless ($displayratio || $displaycount || $clicksratio || $clicksfrom) { + print ""; + } + $runtime = $time - $start + 1; + } + else { + unless ($displayratio || $displaycount || $clicksratio || $clicksfrom) { + print ""; + } + } + $average = 0; + if (($weight > 0) && ($runtime > 86400)) { + &GetAverage; + } + unless ($displayratio || $clicksratio) { + if ($maxtype eq "D") { + ($sec,$min,$hour,$mday,$mon,$year, + $wday,$yday,$isdst) = localtime($max+($ADVHourOffset*3600)); + $year += 1900; + print ""; + } + elsif ($maxtype eq "N") { + print ""; + } + else { + print ""; + } + } + if ($image || $raw || $shown || $visits) { + print ""; + if ($expired || ($weight < 1)) { + print ""; + } + elsif ($average > 0) { + print ""; + } + else { + print ""; + } + print ""; + print ""; + } + print "
          $text{'2012'}

          $text{'2030'}"; + print "

          $text{'2016'}

          $text{'2031'}"; + print "

          $text{'2018'}

          $text{'2019'}

          $mday $months[$mon] $year$mday $months[$mon] $year"; + unless ($max > $time) { + $expired = 1; + print "
          $text{'2100'}"; + } + print "
          $text{'2101'}",&commas($max); + if ($maxtype eq "C") { + print " $text{'2110'}"; + if (($average == 0) || ($shown == 0) || ($visits == 0)) { + print "
          $text{'2102'}"; + } + elsif ($max > $visits) { + $daystogo = (($max-$visits)/($average*($visits/$shown))); + $calculatedend = $time+($daystogo*86400); + ($sec,$min,$hour,$mday,$mon,$year, + $wday,$yday,$isdst) = localtime($calculatedend+($ADVHourOffset*3600)); + $year += 1900; + print "
          (~ $mday $months[$mon] $year)"; + } + else { + $expired = 1; + print "
          $text{'2100'}"; + } + } + else { + print " $text{'2111'}"; + if ($average == 0) { + print "
          $text{'2102'}"; + } + elsif ($max > $shown) { + $daystogo = (($max-$shown)/$average); + $calculatedend = $time+($daystogo*86400); + ($sec,$min,$hour,$mday,$mon,$year, + $wday,$yday,$isdst) = localtime($calculatedend+($ADVHourOffset*3600)); + $year += 1900; + print "
          (~ $mday $months[$mon] $year)"; + } + else { + $expired = 1; + print "
          $text{'2100'}"; + } + } + print "
          ",&commas($shown),"--",&commas($average),"$text{'2020'}",&commas($visits),"$perc$ratio

          \n"; + unless ($image || $raw) { + print "

          $text{'2120'}\n"; + } + if ($displayratio || $clicksratio) { + unless ($NoBanners) { + if ($displaycount<1) { $displaycount = "0"; } + print "

          $text{'2121'} "; + print &commas($displaycount)," $text{'2122'}"; + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "$text{'2123'} "; + print &commas($clicksfrom)," $text{'2124'}"; + } + print "$text{'2125'} "; + $earnings = 0; + if ($displayratio > 0) { $earnings = int($displaycount/$displayratio); } + if ($clicksratio > 0) { $earnings += ($clicksfrom*$clicksratio); } + print "$text{'2126'} "; + print &commas($earnings)," $text{'2127'}"; + if ($displayratio > 0) { + print " $text{'2128'} "; + print "$displayratio $text{'2129'}"; + } + if (($displayratio > 0) && ($clicksratio > 0)) { + print "$text{'2130'}"; + } + if ($clicksratio > 0) { + print " $clicksratio $text{'2131'}"; + } + print "$text{'2132'}"; + unless ($max == $earnings) { + print " $text{'2133'} "; + print &commas($max-$earnings); + print " $text{'2134'}"; + } + print "\n"; + } + print "

          $text{'2135'}\n"; + $HTMLCode = ""; + if ($ExchangeName) { + $HTMLCode = "<!-- Begin $ExchangeName Code -->\n
          "; + } + unless ($ExchangeBorder) { $ExchangeBorder = "0"; } + $HTMLCode .= "<P><CENTER>"; + if ($ExchangeLogo + && (($ExchangeLogoPosition =~ /^t/i) + || ($ExchangeLogoPosition =~ /^l/i) + || ($ExchangeLogoPosition =~ /^1/i) + || !($ExchangeLogoPosition))) { + if ($ExchangeURL) { + $HTMLCode .= "<A HREF="$ExchangeURL""; + $HTMLCode .= " $DefaultLinkAttribute>"; + } + $HTMLCode .= "<IMG SRC="$ExchangeLogo""; + if ($ExchangeLogoHeight && $ExchangeLogoWidth) { + $HTMLCode .= " WIDTH=$ExchangeLogoWidth"; + $HTMLCode .= " HEIGHT=$ExchangeLogoHeight"; + } + if ($ExchangeName) { + $HTMLCode .= " ALT="$ExchangeName""; + } + $HTMLCode .= " BORDER=$ExchangeBorder>"; + if ($ExchangeURL) { + $HTMLCode .= "</A>"; + } + if ($ExchangeLogoPosition =~ /^t/i) { + $HTMLCode .= "<BR>"; + } + } + if ($JavaScriptExchange) { + $HTMLCode .= "<SCRIPT LANGUAGE="JavaScript" "; + $HTMLCode .= "SRC="$nonssi_cgi?"; + $HTMLCode .= "jscript;member=$name"; + if ($displayzone) { + $HTMLCode .= ";zone=$displayzone"; + } + $HTMLCode .= "">"; + $HTMLCode .= "</SCRIPT>"; + $HTMLCode .= "<NOSCRIPT>"; + } + if ($IFRAMEexchange) { + $HTMLCode .= "<IFRAME SRC="$nonssi_cgi?"; + $HTMLCode .= "iframe;member=$name"; + if ($displayzone) { + $HTMLCode .= ";zone=$displayzone"; + } + $HTMLCode .= """; + $HTMLCode .= " MARGINWIDTH=0 MARGINHEIGHT=0 HSPACE=0 VSPACE=0"; + $HTMLCode .= " FRAMEBORDER=0 SCROLLING=NO"; + if ($ExchangeBannerHeight && $ExchangeBannerWidth) { + $IFRAMEWidth = $ExchangeBannerWidth+($DefaultBorder*2); + $IFRAMEHeight = $ExchangeBannerHeight+($DefaultBorder*2); + $HTMLCode .= " WIDTH=$IFRAMEWidth"; + $HTMLCode .= " HEIGHT=$IFRAMEHeight"; + } + $HTMLCode .= ">"; + } + $HTMLCode .= "<A HREF="$nonssi_cgi?"; + $HTMLCode .= "member=$name;banner=NonSSI;page=01"; + if ($displayzone) { + $HTMLCode .= ";zone=$displayzone"; + } + $HTMLCode .= """; + $HTMLCode .= " $DefaultLinkAttribute>"; + $HTMLCode .= "<IMG SRC="$nonssi_cgi?"; + $HTMLCode .= "member=$name;page=01"; + if ($displayzone) { + $HTMLCode .= ";zone=$displayzone"; + } + $HTMLCode .= """; + if ($ExchangeBannerHeight && $ExchangeBannerWidth) { + $HTMLCode .= " WIDTH=$ExchangeBannerWidth"; + $HTMLCode .= " HEIGHT=$ExchangeBannerHeight"; + } + if ($ExchangeName) { + $HTMLCode .= " ALT="$ExchangeName""; + } + $HTMLCode .= " BORDER=$DefaultBorder></A>"; + if ($IFRAMEexchange) { + $HTMLCode .= "</IFRAME>"; + } + if ($JavaScriptExchange) { + $HTMLCode .= "</NOSCRIPT>"; + } + if ($ExchangeLogo + && (($ExchangeLogoPosition =~ /^b/i) + || ($ExchangeLogoPosition =~ /^r/i))) { + if ($ExchangeLogoPosition =~ /^b/i) { + $HTMLCode .= "<BR>"; + } + if ($ExchangeURL) { + $HTMLCode .= "<A HREF="$ExchangeURL""; + $HTMLCode .= " $DefaultLinkAttribute>"; + } + $HTMLCode .= "<IMG SRC="$ExchangeLogo""; + if ($ExchangeLogoHeight && $ExchangeLogoWidth) { + $HTMLCode .= " WIDTH=$ExchangeLogoWidth"; + $HTMLCode .= " HEIGHT=$ExchangeLogoHeight"; + } + if ($ExchangeName) { + $HTMLCode .= " ALT="$ExchangeName""; + } + $HTMLCode .= " BORDER=$ExchangeBorder>"; + if ($ExchangeURL) { + $HTMLCode .= "</A>"; + } + } + if ($ExchangeName && !($ExchangeLogo)) { + $HTMLCode .= "<BR><SMALL>"; + if ($ExchangeURL) { + $HTMLCode .= "<A HREF="$ExchangeURL""; + $HTMLCode .= " $DefaultLinkAttribute>"; + } + $HTMLCode .= "$ExchangeName"; + if ($ExchangeURL) { + $HTMLCode .= "</A>"; + } + $HTMLCode .= "</SMALL>"; + } + $HTMLCode .= "</CENTER>"; + if ($ExchangeName) { + $HTMLCode .= "\n
          <!-- End $ExchangeName Code -->\n"; + } + print "

          "; + print ""; + print "
          \n"; + print "

          $text{'2150'}\n"; + } + print "

          "; + if (($AllowUserEdit || $cryptword) && !($groupstatus)) { + print "

          \n"; + print "\n"; + print "\n"; + print "\n\n"; + if ($UserUploadDir) { + print "\n"; + print "\n"; + print "\n\n"; + } + print "\n", + "\n"; + if ($cryptword) { + print "\n"; + } + print ""; + print "\n"; + print "\n"; + print "
          "; + if ($cryptword) { + print ""; + print "
          "; + if ($cryptword) { + print "\n"; + } + print ""; + print "
          \n"; + } + print "

          \n"; + if ($LogByZone) { + print "\n"; + } + print "\n"; + print "\n"; + if ($ADVLogIP) { + print "\n"; + } + print "
          \n"; + print "\n"; + if ($groupstatus) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($groupstatus) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($groupstatus) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($groupstatus) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "

          \n"; + if ($email && $INPUT{'welcomeletter'}) { + open (WELCOME, "<$ADVadverts_dir/welcome.txt"); + $body = ""; + while (defined($line = )) { + $body .= $line; + } + close (WELCOME); + $HTMLCode =~ s/
          //g; + $HTMLCode =~ s/<//g; + $HTMLCode =~ s/"/"/g; + $body =~ s/<--UserID-->/$name/g; + $body =~ s/<--Password-->/$pass/g; + $body =~ s/<--HTMLCode-->/$HTMLCode/g; + &SendMail($email,"welcome"); + } + &ShowAdvert; +} + +sub GetAverage { + $subdir = substr($name,0,1); + $subdir .= "/$name"; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$name.log"); + @lines = ; + close (DISPLAY); + chomp (@lines); + @reverselines = reverse (@lines); + $avexposures = 0; + $linecount = 0; + foreach $line (@reverselines) { + next if (length($line)<10); + ($acc,$type) = ($line =~ + /^(\d\d\d\d\d\d\d\d\d\d) \d\d \d\d \d\d\d\d (\w)$/); + next unless ($type eq "E"); + $linecount++; + next if ($linecount < 2); + last if ($linecount > 8); + $avexposures += int($acc); + } + unless ($linecount > 8) { + $avexposures -= int($acc); + } + if (($avexposures < 1) || ($linecount < 3)) { + return; + } + $average = int(($avexposures/($linecount-2))+.5); +} + +sub logbyzone { + $AccountName = $INPUT{'advert'}; + &CheckName; + &ConfirmUserPassword; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.txt"); + @lines = ; + close (DISPLAY); + chomp (@lines); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          $text{'2210'} "; + print "$AccountName $text{'2211'}:\n"; + if (@lines > 21) { + foreach $key (21..@lines-1) { + if ($lines[$key] =~ /(\S+ \S+) (\S) (\d+)/) { + $zone = $1; + $type = $2; + $count = $3; + if ($type eq "E") { $exposures{$zone} += $count; } + if ($type eq "C") { + $clicks{$zone} += $count; + unless ($exposures{$zone}) { $exposures{$zone} = "0"; } + } + } + } + print "

          \n"; + print ""; + print ""; + print ""; + print ""; + print ""; + print ""; + print ""; + print "\n"; + foreach $key (sort (keys %exposures)) { + ($zone,$member) = split(/\s/,$key); + unless ($clicks{$key}) { $clicks{$key} = "0"; } + print ""; + if (($exposures{$key} == 0) || ($clicks{$key} == 0)) { + $perc = "$text{'2020'}"; + $ratio = "$text{'2020'}"; + } + else { + $perc = ((100*($clicks{$key}/$exposures{$key}))+.05001); + $ratio = (($exposures{$key}/$clicks{$key})+.5001); + } + unless ($perc eq "$text{'2020'}") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + unless ($ratio eq "$text{'2020'}") { + $ratio =~ s/(\d+)\.\d.*/$1/; + $ratio = $ratio.":1"; + } + print ""; + print ""; + print ""; + print ""; + print ""; + print ""; + print "\n"; + } + print "
          $text{'2212'}

          $text{'2213'}

          $text{'2214'}

          $text{'2215'}

          $text{'2018'}

          $text{'2019'}

          $zone$member",&commas($exposures{$key}),"",&commas($clicks{$key}),"$perc$ratio
          \n"; + } + print "

          \n"; + print "\n"; + print "\n"; + print "\n"; + if ($ADVLogIP) { + print "\n"; + } + print "
          \n"; + print "\n"; + if ($cryptword) { + print "\n"; + } + print "\n"; + print " "; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + &Footer; +} + +sub dailystats { + $AccountName = $INPUT{'advert'}; + &CheckName; + &ConfirmUserPassword; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.log") || &Error_NoStats; + @lines = ; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + next if (length($line) < 10); + ($acc,$logstring) = ($line =~ + /^(\d\d\d\d\d\d\d\d\d\d) (\d\d \d\d \d\d\d\d \w)$/); + $accesses{$logstring} = int($acc); + ($mday,$mon,$year,$type) = ($logstring =~ + /^(\d+) (\d+) (\d+) (\w)/); + if ($type eq "E") { + $beingshown = 1; + $TotalE += int($acc); + if (int($acc) > $MaxE) { $MaxE = int($acc); } + } + elsif ($type eq "C") { + $beingshown = 1; + $TotalC += int($acc); + if (int($acc) > $MaxC) { $MaxC = int($acc); } + } + elsif ($type eq "S") { + $bannex = 1; + $TotalS += int($acc); + if (int($acc) > $MaxS) { $MaxS = int($acc); } + } + elsif ($type eq "X") { + $bannex = 1; + $TotalX += int($acc); + if (int($acc) > $MaxX) { $MaxX = int($acc); } + } + else { next; } + unless ($startday) { + &date_to_count(int($mon),int($mday),($year-1900)); + $startday = $perp_days; + } + } + &date_to_count(int($mon),int($mday),($year-1900)); + $endday = $perp_days; + if ((($endday-$startday) > 34) && !($INPUT{'FullDailyList'})) { + $startday = $endday-34; + $ShortenedList = 1; + $TotalE = $MaxE = 0; + $TotalC = $MaxC = 0; + $TotalS = $MaxS = 0; + $TotalX = $MaxX = 0; + foreach $daycount ($startday..$endday) { + &count_to_date($daycount); + if ($perp_mon < 10) { $perp_mon = "0$perp_mon"; } + if ($perp_day < 10) { $perp_day = "0$perp_day"; } + $perp_year = $perp_year + 1900; + $exposures = "$perp_day $perp_mon $perp_year E"; + $clicks = "$perp_day $perp_mon $perp_year C"; + $banners = "$perp_day $perp_mon $perp_year S"; + $clicksfrom = "$perp_day $perp_mon $perp_year X"; + $TotalE += $accesses{$exposures}; + $TotalC += $accesses{$clicks}; + $TotalS += $accesses{$banners}; + $TotalX += $accesses{$clicksfrom}; + if ($accesses{$exposures} > $MaxE) { $MaxE = $accesses{$exposures}; } + if ($accesses{$clicks} > $MaxC) { $MaxC = $accesses{$clicks}; } + if ($accesses{$banners} > $MaxS) { $MaxS = $accesses{$banners}; } + if ($accesses{$clicksfrom} > $MaxX) { $MaxX = $accesses{$clicksfrom}; } + } + } + &Header("$text{'1000'}","$text{'1001'}"); + print "

          $text{'2220'} "; + print "$AccountName $text{'2221'}"; + if ($ShortenedList) { + print "
          $text{'2222'}"; + } + elsif ($INPUT{'FullDailyList'}) { + print "
          $text{'2223'}"; + } + print ":
          \n"; + print "

          \n"; + print ""; + print ""; + if ($bannex) { + print ""; + print ""; + $ColCountA = 2; + if ($INPUT{'showclicksfrom'}) { + print ""; + print ""; + $ColCountA += 6; + } + } + if ($beingshown) { + print ""; + print ""; + print ""; + print ""; + $ColCountB = 8; + } + $daycounter = (($endday-$startday)+1); + if ($TotalE) { $MultE = ((49.5/($MaxE/$TotalE))/$daycounter); } + if ($TotalC) { $MultC = ((49.5/($MaxC/$TotalC))/$daycounter); } + if ($TotalS) { $MultS = ((49.5/($MaxS/$TotalS))/$daycounter); } + if ($TotalX) { $MultX = ((49.5/($MaxX/$TotalX))/$daycounter); } + foreach $daycount ($startday..$endday) { + print ""; + if (($daycount > $startday) + && ($daycount-(int($daycount/7)*7)==3)) { + print ""; + if ($ColCountA) { + print ""; + print ""; + } + if ($ColCountB) { + print ""; + print ""; + } + print "\n"; + print ""; + } + &count_to_date($daycount); + if ($perp_mon < 10) { $perp_mon = "0$perp_mon"; } + if ($perp_day < 10) { $perp_day = "0$perp_day"; } + $perp_year = $perp_year + 1900; + print ""; + $banners = "$perp_day $perp_mon $perp_year S"; + $clicksfrom = "$perp_day $perp_mon $perp_year X"; + $exposures = "$perp_day $perp_mon $perp_year E"; + $clicks = "$perp_day $perp_mon $perp_year C"; + $banners = $accesses{$banners}; + if (($TotalS == 0) || ($banners==$TotalS)) { $bannerspercent = 0; } + else { $bannerspercent=int((($banners/$TotalS)*($daycounter*$MultS))+.5); } + $clicksfrom = $accesses{$clicksfrom}; + if (($TotalX == 0) || ($clicksfrom==$TotalX)) { $clicksfrompercent = 0; } + else { $clicksfrompercent=int((($clicksfrom/$TotalX)*($daycounter*$MultX))+.5); } + $exposures = $accesses{$exposures}; + if (($TotalE == 0) || ($exposures==$TotalE)) { $exposurespercent = 0; } + else { $exposurespercent=int((($exposures/$TotalE)*($daycounter*$MultE))+.5); } + $clicks = $accesses{$clicks}; + if (($TotalC == 0) || ($clicks==$TotalC)) { $clickspercent = 0; } + else { $clickspercent=int((($clicks/$TotalC)*($daycounter*$MultC))+.5); } + if ($banners < 1) { $banners = "0"; } + if ($clicksfrom < 1) { $clicksfrom = "0"; } + if ($exposures < 1) { $exposures = "0"; } + if ($clicks < 1) { $clicks = "0"; } + if ($bannex) { + print ""; + print ""; + if ($bannerspercent==0) { print ""; } + else { print ""; } + if ($INPUT{'showclicksfrom'}) { + print ""; + if ($clicksfrompercent==0) { print ""; } + else { print ""; } + if ($banners == 0) { $perc = "-"; } + elsif ($clicksfrom == 0) { $perc = "-"; } + else { $perc = ((100*($clicksfrom/$banners))+.05001); } + unless ($perc eq "-") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + print ""; + } + } + if ($beingshown) { + print ""; + print ""; + if ($exposurespercent==0) { print ""; } + else { print ""; } + print ""; + if ($clickspercent==0) { print ""; } + else { print ""; } + if ($exposures == 0) { $perc = "-"; } + elsif ($clicks == 0) { $perc = "-"; } + else { $perc = ((100*($clicks/$exposures))+.05001); } + unless ($perc eq "-") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + print ""; + print "\n"; + } + } + print "
          $text{'2224'}

                   $text{'2040'}"; + print "

          $text{'2041'}"; + print "

          $text{'2018'}

                   $text{'2030'}"; + print "

          $text{'2031'}"; + print "

          $text{'2018'}


           
           
          $perp_day $months[$perp_mon-1] $perp_year  ",&commas($banners)," 
           ",&commas($clicksfrom)," 
           $perc  ",&commas($exposures)," 
           ",&commas($clicks)," 
           $perc
          \n"; + if ($ShortenedList) { + print "

          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + } + elsif ($INPUT{'FullDailyList'}) { + print "

          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + } + print "

          \n"; + print "\n"; + if ($LogByZone) { + print "\n"; + } + print "\n"; + if ($ADVLogIP) { + print "\n"; + } + print "
          \n"; + print "\n"; + if ($cryptword) { + print "\n"; + } + print "\n"; + print " "; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + &Footer; +} + +sub monthlystats { + $AccountName = $INPUT{'advert'}; + &CheckName; + &ConfirmUserPassword; + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.log") || &Error_NoStats; + @lines = ; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + next if (length($line) < 10); + ($acc,$logstring) = ($line =~ + /^(\d\d\d\d\d\d\d\d\d\d) \d\d (\d\d \d\d\d\d \w)$/); + $accesses{$logstring} += int($acc); + ($mon,$year,$type) = ($logstring =~ + /^(\d+) (\d+) (\w)/); + if ($type eq "E") { + $beingshown = 1; + $TotalE += int($acc); + } + elsif ($type eq "C") { + $beingshown = 1; + $TotalC += int($acc); + } + elsif ($type eq "S") { + $bannex = 1; + $TotalS += int($acc); + } + elsif ($type eq "X") { + $bannex = 1; + $TotalX += int($acc); + } + else { next; } + unless ($startyear) { + $startyear = $year; + $startmon = $mon; + } + } + $endyear = $year; + $endmon = $mon; + &Header("$text{'1000'}","$text{'1001'}"); + print "

          $text{'2230'} "; + print "$AccountName $text{'2231'}"; + print ":\n"; + print "

          \n"; + print ""; + print ""; + if ($bannex) { + print ""; + print ""; + if ($INPUT{'showclicksfrom'}) { + print ""; + print ""; + } + } + if ($beingshown) { + print ""; + print ""; + print ""; + print ""; + } + foreach $year ($startyear..$endyear) { + if ($year == $startyear) { $firstmon = $startmon; } + else { $firstmon = "01"; } + if ($year == $endyear) { $lastmon = $endmon; } + else { $lastmon = 12; } + foreach $month ($firstmon..$lastmon) { + $TestS = "$month $year S"; + $TestX = "$month $year X"; + $TestE = "$month $year E"; + $TestC = "$month $year C"; + if ($accesses{$TestS} > $MaxS) { $MaxS = $accesses{$TestS}; } + if ($accesses{$TestX} > $MaxX) { $MaxX = $accesses{$TestX}; } + if ($accesses{$TestE} > $MaxE) { $MaxE = $accesses{$TestE}; } + if ($accesses{$TestC} > $MaxC) { $MaxC = $accesses{$TestC}; } + $monthcounter++; + } + } + if ($TotalE) { $MultE = ((49.5/($MaxE/$TotalE))/$monthcounter); } + if ($TotalC) { $MultC = ((49.5/($MaxC/$TotalC))/$monthcounter); } + if ($TotalS) { $MultS = ((49.5/($MaxS/$TotalS))/$monthcounter); } + if ($TotalX) { $MultX = ((49.5/($MaxX/$TotalX))/$monthcounter); } + foreach $year ($startyear..$endyear) { + if ($year == $startyear) { $firstmon = $startmon; } + else { $firstmon = "01"; } + if ($year == $endyear) { $lastmon = $endmon; } + else { $lastmon = 12; } + foreach $month ($firstmon..$lastmon) { + print ""; + print ""; + unless (length($month) == 2) { $month = "0".$month; } + $banners = "$month $year S"; + $clicksfrom = "$month $year X"; + $exposures = "$month $year E"; + $clicks = "$month $year C"; + $banners = $accesses{$banners}; + if (($TotalS == 0) || ($banners==$TotalS)) { $bannerspercent = 0; } + else { $bannerspercent=int((($banners/$TotalS)*($monthcounter*$MultS))+.5); } + $clicksfrom = $accesses{$clicksfrom}; + if (($TotalX == 0) || ($clicksfrom==$TotalX)) { $clicksfrompercent = 0; } + else { $clicksfrompercent=int((($clicksfrom/$TotalX)*($monthcounter*$MultX))+.5); } + $exposures = $accesses{$exposures}; + if (($TotalE == 0) || ($exposures==$TotalE)) { $exposurespercent = 0; } + else { $exposurespercent=int((($exposures/$TotalE)*($monthcounter*$MultE))+.5); } + $clicks = $accesses{$clicks}; + if (($TotalC == 0) || ($clicks==$TotalC)) { $clickspercent = 0; } + else { $clickspercent=int((($clicks/$TotalC)*($monthcounter*$MultC))+.5); } + if ($banners < 1) { $banners = "0"; } + if ($clicksfrom < 1) { $clicksfrom = "0"; } + if ($exposures < 1) { $exposures = "0"; } + if ($clicks < 1) { $clicks = "0"; } + if ($bannex) { + print ""; + print ""; + if ($bannerspercent==0) { print ""; } + else { print ""; } + if ($INPUT{'showclicksfrom'}) { + print ""; + if ($clicksfrompercent==0) { print ""; } + else { print ""; } + if ($banners == 0) { $perc = "-"; } + elsif ($clicksfrom == 0) { $perc = "-"; } + else { $perc = ((100*($clicksfrom/$banners))+.05001); } + unless ($perc eq "-") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + print ""; + } + } + if ($beingshown) { + print ""; + print ""; + if ($exposurespercent==0) { print ""; } + else { print ""; } + print ""; + if ($clickspercent==0) { print ""; } + else { print ""; } + if ($exposures == 0) { $perc = "-"; } + elsif ($clicks == 0) { $perc = "-"; } + else { $perc = ((100*($clicks/$exposures))+.05001); } + unless ($perc eq "-") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + print ""; + print "\n"; + } + } + } + print "
          $text{'2232'}

                   $text{'2040'}"; + print "

          $text{'2041'}"; + print "

          $text{'2018'}

                   $text{'2030'}"; + print "

          $text{'2031'}"; + print "

          $text{'2018'}

          $months[$month-1] $year  ",&commas($banners)," 
           ",&commas($clicksfrom)," 
           $perc  ",&commas($exposures)," 
           ",&commas($clicks)," 
           $perc
          \n"; + print "

          \n"; + print "\n"; + if ($LogByZone) { + print "\n"; + } + print "\n"; + if ($ADVLogIP) { + print "\n"; + } + print "
          \n"; + print "\n"; + if ($cryptword) { + print "\n"; + } + print "\n"; + print " "; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + &Footer; +} + +sub iplog { + $AccountName = $INPUT{'advert'}; + &CheckName; + &ConfirmUserPassword; + &Header("$text{'1000'}","$text{'1001'}"); + print "

          $text{'2240'} ", + "$AccountName $text{'2241'}:\n", + "

          $text{'2242'}\n", + "

          ";
          +	($mday,$mon) = (localtime($time-86400+($ADVHourOffset*3600)))[3,4];
          +	if ($mday < 10) { $mday = "0".$mday; }
          +	$mon++;
          +	if ($mon < 10) { $mon = "0".$mon; }
          +	open (DISPLAY, "$ADVadverts_dir/$subdir/$AccountName.$mon$mday.log");
          +	&ShowIPs;
          +	close (DISPLAY);
          +	($mday,$mon) = (localtime($time+($ADVHourOffset*3600)))[3,4];
          +	if ($mday < 10) { $mday = "0".$mday; }
          +	$mon++;
          +	if ($mon < 10) { $mon = "0".$mon; }
          +	open (DISPLAY, "$ADVadverts_dir/$subdir/$AccountName.$mon$mday.log");
          +	&ShowIPs;
          +	close (DISPLAY);
          +	print "
          \n"; + print "

          $text{'2243'}: ",&commas($ExposureCount),"\n"; + print "
          $text{'2244'}: ",&commas($ClickCount),"\n"; + print "
          $text{'2245'}: ",&commas($IPCount),"\n"; + if ($IPCount<1) { $AverageEntries = 0; } + else { $AverageEntries = (($ExposureCount+$ClickCount)/$IPCount)+.05; } + if ($AverageEntries < 10) { + $AverageEntries =~ s/(...).*/$1/; + } + else { + $AverageEntries =~ s/(....).*/$1/; + } + print "

          $text{'2246'}: ${AverageEntries}\n"; + print "

          \n"; + print "\n"; + if ($LogByZone) { + print "\n"; + } + print "\n"; + print "\n"; + print "
          \n"; + print "\n"; + if ($cryptword) { + print "\n"; + } + print "\n"; + print " "; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($clicksratio || $cryptword || $ShowClicksFrom) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + print "\n"; + if ($INPUT{'groupstatus'}) { + print "\n"; + } + print "\n"; + if ($cryptword) { + print "\n"; + } + if ($INPUT{'showclicksfrom'}) { + print "\n"; + } + print ""; + print "
          \n"; + &Footer; +} + +sub ShowIPs { + if ($IPLog) { dbmopen(%Resolved,"$IPLog",0666); } + while () { + next if (length($_) < 5); + if (/([^\s]* E) ([^\s]*)\n/) { + $ExposureCount ++; + $ThisTime = $1; + $ThisIP = $2; + } + elsif (/([^\s]* C) ([^\s]*)\n/) { + $ClickCount ++; + $ThisTime = $1; + $ThisIP = $2; + } + $ThisTrimmedIP = $ThisIP; + if ($ThisTrimmedIP =~ /\d+\.\d+\.\d+\.\d+/) { + $ThisTrimmedIP =~ s/(\d+\.\d+\.\d+)\.\d+/$1\.XXX/; + if ($Resolved{$ThisTrimmedIP} + && ($Resolved{$ThisTrimmedIP} ne "unresolved")) { + foreach $key (8..15) { + if (length($ThisIP)<$key) { $ThisIP .= " "; } + } + $ThisIP .= " $Resolved{$ThisTrimmedIP}"; + } + } + unless ($NoPrintIPs) { print "$mon/$mday $ThisTime $ThisIP\n"; } + $IPCount{$ThisIP} ++; + if ($IPCount{$ThisIP} == 1) { + $IPCount ++; + } + } + if ($IPLog) { dbmclose(%Resolved); } +} + +sub masteriplog { + &ConfirmAdminPassword(1); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          ", + "Master IP Address Report\n", + "

          The following report details the IP addresses which ", + "have seen or clicked on banners in the rotation ", + "in the last $MasterIPLogDays days.\n"; + $NoPrintIPs = 1; + foreach $key (a..z,0..9) { + opendir (FILES,"$ADVadverts_dir/$key"); + @files = readdir(FILES); + closedir (FILES); + foreach $file (@files) { + next unless (-d "$ADVadverts_dir/$key/$file"); + opendir (SUBFILES,"$ADVadverts_dir/$key/$file"); + @subfiles = readdir(SUBFILES); + closedir (SUBFILES); + foreach $subfile (@subfiles) { + next unless ($subfile=~/\d\d\d\d\.log/); + open (DISPLAY, "$ADVadverts_dir/$key/$file/$subfile"); + &ShowIPs; + close (DISPLAY); + } + } + } + print "

          Total exposures logged: ",&commas($ExposureCount),"\n"; + print "
          Total clicks logged: ",&commas($ClickCount),"\n"; + print "
          Total IP addresses logged: ",&commas($IPCount),"\n"; + if ($IPCount<1) { $AverageEntries = 0; } + else { $AverageEntries = (($ExposureCount+$ClickCount)/$IPCount)+.05; } + if ($AverageEntries < 10) { + $AverageEntries =~ s/(...).*/$1/; + } + else { + $AverageEntries =~ s/(....).*/$1/; + } + print "

          Average log entries per IP address: ${AverageEntries}\n"; + print "

          The Top 50 Most Active IP Addresses:\n"; + print "

          \n";
          +	foreach $key (sort ByCount keys(%IPCount)) {
          +		last if ($Counter > 49);
          +		$ip = $key;
          +		printf "%10s%-s\n",&commas($IPCount{$key}),"       $ip";
          +		$Counter++;
          +	}
          +	print "
          \n"; + &LinkBack; + &Footer; +} + +sub ByCount { + $IPCount{$b}<=>$IPCount{$a}; +} + +sub cheatercheck { + &ConfirmAdminPassword(1); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          ", + ""Cheater Check" Report\n", + "

          The following report lists the number of banners shown on, ", + "and the number of click-thrus from, each exchange member site ", + "which "earns" exposures. Any sites with unusually ", + "high or low click-thru ratios may be trying to "cheat" ", + "the system by artificially inflating one or the other of those ", + "counts.\n"; + open (LIST, "<$ADVadverts_dir/adlist.txt"); + @advertisements = ; + close (LIST); + chomp (@advertisements); + @sortedadverts = sort (@advertisements); + &ADVLockOpen (DBMLIST, "dbmlist.txt"); + if ($ADVlockerror) { &Error_DBM; } + else { + &ADVDBMOpen; + if ($ADVdbmerror) { &Error_DBM; } + else { + print "

          \n", + "", + "", + "", + "", + "", + "\n"; + foreach $advertiser (@sortedadverts) { + $name = $advertiser; + next if (length($advertiser) < 1); + ($max,$shown,$visits,$image,$start,$weight, + $zone,$raw,$displayratio,$clicksfrom) = split(/\t/,$DBMList{$name}); + ($displayratio,$displaycount) = split(/\|/, $displayratio); + ($clicksfrom,$clicksratio) = split(/\|/, $clicksfrom); + next unless (($displayratio > 0) || ($displaycount > 0) + || ($clicksfrom > 0) || ($clicksratio > 0)); + if (($displaycount == 0) || ($clicksfrom == 0)) { + $perc = "$text{'2020'}"; + $ratio = "$text{'2020'}"; + } + else { + $perc = ((100*($clicksfrom/$displaycount))+.05001); + $ratio = (($displaycount/$clicksfrom)+.5001); + } + unless ($perc eq "$text{'2020'}") { + $perc =~ s/(\d+\.\d).*/$1/; + $perc = $perc."%"; + } + unless ($ratio eq "$text{'2020'}") { + $ratio =~ s/(\d+)\.\d.*/$1/; + $ratio = $ratio.":1"; + } + print "\n", + "\n"; + print ""; + print ""; + print "\n"; + } + &ADVDBMClose; + print "
          Account

          Banners Shown
          on Your Site


          Clicks From
          Your Site


          %

          Ratio

          $advertiser",&commas($displaycount),"",&commas($clicksfrom),"$perc$ratio
          \n"; + } + } + print "


          "; + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &LinkBack; + &Footer; +} + +sub ShowAdvert { + @image = split(/\|/,$image); + $url =~ s//$time/g; + if ($raw || $image) { + print "

          "; + } + if ($raw) { + $realraw = $raw; + $realraw =~ s//\n/g; + $realraw =~ s//$time/g; + $realraw =~ s///g; + print ""; + } + elsif ($image) { + print ""; + } + if ($raw || $image) { + print "
          $realraw"; + foreach $image (@image) { + $img = $image; + $img =~ s//$time/g; + if ($NotFirst) { print "

          "; } + else { $NotFirst=1; } + if ($text && ($texttype eq "T")) { + print "$text
          "; + } + if ($url) { + print ""; + } + print "\"$alt\"";"; + if ($url) { print ""; } + if ($text && ($texttype eq "B")) { + print "
          $text"; + } + print "\n"; + } + print "

          \n"; + } + if ($url) { + $printurl = $url; + $printurl =~ s/%7c/\|/g; + print "

          Destination: "; + print "$printurl\n"; + } + if ($username || $email) { + if ($url) { print "
          "; } + else { print "

          "; } + print "Account Holder: "; + if ($email) { + print ""; + } + if ($username) { print "$username"; } + else { print "$email"; } + if ($email) { + print ""; + } + print "\n"; + } +} + +sub resetadminlog { + &ConfirmAdminPassword(1); + unlink "$ADVadverts_dir/adminlog.txt"; + if ($AdminDisplaySetup) { &defineview; } + else { + $INPUT{'whichtype'} = "pending established groups"; + $INPUT{'whichtime'} = "active expired disabled"; + $INPUT{'whichzone'} = ""; + &reviewall; + } +} + +sub adminlog { + &ConfirmAdminPassword(1); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          ", + "Admin Accesses Report\n", + "

          The following report lists the IP addresses ", + "which have accessed administrative functions.\n"; + print "

          \n";
          +	open (ADMINLOG,"$ADVadverts_dir/adminlog.txt");
          +	while () { print "$_"; }
          +	close (ADMINLOG);
          +	print "
          \n"; + print "
          \n", + "

          \n", + "\n", + "

          \n", + "

          \n"; + &LinkBack; + &Footer; +} + +sub RenameAccount { + &ConfirmAdminPassword(1); + &ADVLockOpen (DBMLIST, "dbmlist.txt"); + if ($ADVlockerror) { &Error_DBM; } + else { + &ADVDBMOpen; + if ($ADVdbmerror) { &Error_DBM; } + else { + $AccountName = $INPUT{'oldname'}; + &CheckName; + $oldname = $AccountName; + $oldsubdir = $subdir; + unless ($DBMList{$oldname}) { + &Header("$text{'9000'}","Rename Error!"); + print "

          No account "$oldname" exists!\n"; + &ADVDBMClose; + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &Footer; + } + $AccountName = $INPUT{'newname'}; + &CheckName; + $newname = $AccountName; + $newsubdir = $subdir; + if ($DBMList{$newname}) { + &Header("$text{'9000'}","Rename Error!"); + print "

          Account name "$newname" is already in use!\n"; + &ADVDBMClose; + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &Footer; + } + unless (-d "$ADVadverts_dir/$newsubdir") { + mkdir ("$ADVadverts_dir/$newsubdir",0777); + chmod 0777,"$ADVadverts_dir/$newsubdir"; + } + opendir (FILES,"$ADVadverts_dir/$oldsubdir"); + @files = readdir(FILES); + closedir (FILES); + foreach $file (@files) { + next if ($file =~ /^\./); + $_ = $file; /^(.+)$/; $file = $1; + $newfile = $file; + $newfile =~ s/$oldname/$newname/; + rename ("$ADVadverts_dir/$oldsubdir/$file","$ADVadverts_dir/$newsubdir/$newfile"); + } + rmdir ("$ADVadverts_dir/$oldsubdir"); + if ($UserUploadDir) { + rename ("$UserUploadDir/$oldname\.gif","$UserUploadDir/$newname\.gif"); + rename ("$UserUploadDir/$oldname\.jpg","$UserUploadDir/$newname\.jpg"); + &ADVLockOpen (COUNT, "$newsubdir/$newname.txt"); + @lines = ; + chomp (@lines); + seek (COUNT,0,0); + foreach $line (@lines) { + $line =~ s/$oldname\.gif/$newname\.gif/; + $line =~ s/$oldname\.jpg/$newname\.jpg/; + print COUNT "$line\n"; + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT,"$newsubdir/$newname.txt"); + } + if (-s "$ADVadverts_dir/adlist.txt") { + &ADVLockOpen (COUNT, "adlist.txt"); + @lines = ; + chomp (@lines); + seek (COUNT,0,0); + foreach $line (@lines) { + if ($line eq $oldname) { print COUNT "$newname\n"; } + else { print COUNT "$line\n"; } + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT,"adlist.txt"); + } + if (-s "$ADVadverts_dir/adnew.txt") { + &ADVLockOpen (COUNT, "adnew.txt"); + @lines = ; + chomp (@lines); + seek (COUNT,0,0); + foreach $line (@lines) { + if ($line eq $oldname) { print COUNT "$newname\n"; } + else { print COUNT "$line\n"; } + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT,"adnew.txt"); + } + $DBMList{$newname} = $DBMList{$oldname}; + delete ($DBMList{$oldname}); + &ADVDBMClose; + } + } + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          Account Renamed\n", + "

          The "$oldname" account has been renamed "$newname."\n"; + &LinkBack; + &Footer; +} + +sub edit { + &ConfirmAdminPassword(1); + if ($INPUT{'reviewone'} && !($INPUT{'editad'})) { + $INPUT{'editad'} = $INPUT{'reviewone'}; + } + if ($INPUT{'basedon'}) { + $AccountName = $INPUT{'basedonad'}; + &CheckName; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + &Header("$text{'9000'}","Name Error!"); + print "

          Account name "$AccountName" is already in use!\n"; + &ADVDBMClose; + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &Footer; + } + $AccountName = $INPUT{'basedonsource'}; + } + else { $AccountName = $INPUT{'editad'}; } + &CheckName; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + $line =~ s/&/&/g; + $line =~ s/>/>/g; + $line =~ s/; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + $line =~ s/&/&/g; + $line =~ s/>/>/g; + $line =~ s/ $time) { $start = $time; } + $displaycount = 0; + $clicksfrom = 0; + } + unless ($weight) { + if ($maxtype) { $weight = "0"; } + else { $weight = $DefaultWeight; } + } + unless ($border) { + if ($maxtype) { $border = "0"; } + else { $border = $DefaultBorder; } + } + unless ($displayratio) { + if ($maxtype) { $displayratio = "0"; } + else { $displayratio = $DefaultDisplayRatio; } + } + unless ($clicksratio) { + if ($maxtype) { $clicksratio = "0"; } + else { $clicksratio = $DefaultClicksRatio; } + } + unless ($target) { + if ($maxtype) { $target = ""; } + else { $target = $DefaultLinkAttribute; } + } + if ($target eq "_top") { $target = "TARGET="_top""; } + unless ($maxtype) { $maxtype = "E"; } + unless ($texttype) { $texttype = "B"; } + unless ($url) { $url = "http://"; } + $image =~ s/\|/\n/g; + unless ($image) { $image = "http://"; } + &Header("$text{'1000'}","$text{'1001'}"); + print "

          \n"; + print "

          Info for the ", + "$AccountName Account:", + "\n", + "

          \n", + "\n", + "\n", + "\n", + "\n", + "\n"; + print "\n"; + print ""; + print "\n", + "\n", + "\n", + "\n"; + if (@zones) { + print "\n"; + print "\n"; + } + else { + print "\n"; + } + $url =~ s/%7c/\|/g; + $image =~ s/%7c/\|/g; + print "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "

          ", + "I. General Information: ", + "The following is general "background" ", + "information. The purpose of the "Name" and "E-Mail" ", + "fields should of course be obvious; the "Password" field records ", + "the password the account holder will use to view his stats. The ", + ""Comments" field can be used for whatever other information ", + "you deem important. (It will be seen only by you, and never by the ", + "account holder, so you may be as candid as you like.) The other ", + "fields help to determine how, where, and how often the account's banner ", + "will be shown.
          Name:
          E-Mail:
          Comments:
          Start Day:"; + if ($start) { ($mday,$mon,$year) = (localtime($start+($ADVHourOffset*3600)))[3,4,5]; } + else { ($mday,$mon,$year) = (localtime($time+($ADVHourOffset*3600)))[3,4,5]; } + $year += 1900; + print " "; + print " "; + print ""; + print "
          (Input the date ", + "on which the account should start running, or leave unaltered ", + "to start the run immediately.)", + "
          Expiration: Never Expires
          Expires on Date: "; + if ($max && ($maxtype eq "D")) { + ($mday,$mon,$year) = (localtime($max+($ADVHourOffset*3600)))[3,4,5]; + $max = "0"; + } + else { ($mday,$mon,$year) = (localtime($time+($ADVHourOffset*3600)))[3,4,5]; } + $year += 1900; + print " "; + print " "; + print "
          "; + unless ($max) { $max = "0"; } + print "
          Expires After: "; + print ""; + print " Exposures Clicks\n"; + print "
          (Input the date on which the run will end, or the maximum number ", + "of exposures or click-thrus to be allowed for the run.)", + "
          Display Ratio: displays earn 1 exposure", + "
          1 click earns
          exposures", + "
          (If this account is to "earn" exposures by ", + "showing other banners, input the appropriate details here.)", + "
          ", + "Note that while either an expiration or a display ", + "ratio must be set, it is not necessary to set both. ", + "If you're running a "banner exchange," ", + "the display ratio will define the rate at which banner exposures ", + "are earned, based upon displays and/or click-thrus generated by ", + "the member. In that case, generally, you'll want to leave the ", + "expiration set either to "0 Exposures" or "Never Expires." ", + "If, on the other hand, you're running straight advertisements, leave the ", + "display ratios set to 0 (or undefined), and simply set the appropriate ", + "expiration criteria instead. Define both only if you're running ", + "an exchange in which the member is to get extra ", + ""bonus" exposures; in that case, define the bonus number ", + "in the "expiration" slot.", + "
          Weight (Wt.):", + "
          (Define how often this banner will be eligible for display. 0 = never, 1 = every cycle through the list, ", + "2 = every other cycle, 3 = every third cycle, etc.)", + "
          Zone(s):"; + foreach $setzone (sort (@zones)) { + print "$setzone\n
          "; + } + print "(Select above, the zones -- or "target categories" -- "; + print "in which this banner should be displayed.)"; + print "
          "; + $displayzone = "\+".$displayzone."\+"; + foreach $setzone (sort (@zones)) { + print "$setzone\n
          "; + } + print "(If this account holder is an exchange member, "; + print "select above, the category or categories of banners which should be displayed on "; + print "his pages.)"; + print "
          Zone(s):"; + print "
          (List the zones -- or "target categories" -- "; + print "in which this banner should be displayed.)"; + print "
          Password:

          ", + "II. Banner Details: ", + "The following information will be used to generate ", + "the account's banner links.
          Site URL:
          Banner URL(s):", + "", + "
          (Input more than one banner URL only if you don't want ", + "distinct performance data for each banner. If you do want to know ", + "individually how each banner performs, create a distinct ", + "account for each one.)", + "
          Link Attributes:", + "
          (Select TARGET or other attributes -- example: TARGET="_blank" -- that should be included ", + "in the banner's link code.)", + "
          Banner Width: pixels
          Banner Height: pixels
          Border:
          ALT Text:
          Link Text:", + "
          Above Banner Below Banner

          ", + "III. "Raw Mode" Information: ", + "If you so choose, you can specify below exactly ", + "how a banner is to appear on your pages. Only use this option if you're sure ", + "you know what you're doing! Anything input here will appear on your pages exactly ", + "as you enter it here; ", + "the information in section II will only be used if this information cannot be displayed ", + "(usually because a banner was called from an IMG tag rather than from an SSI, IFRAME or JavaScript tag).
          "Raw" HTML:", + "

          \n", + "

          \n", + "\n", + "\n", + "Check here to reset account exposures & clicks: ", + ""; + if ($mailprog && (-s "$ADVadverts_dir/welcome.txt")) { + print "
          Check here to send a welcome letter: ", + ""; + } + if ($cryptword) { + print "\n"; + } + print "

          \n"; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + if ($mailprog && (-s "$ADVadverts_dir/reject.txt") && $email) { + print "

          Check here to send a rejection letter: ", + ""; + } + print "

          "; + print "\n"; + } + print "

          \n"; + &Footer; +} + +sub UserEdit { + $AccountName = $INPUT{'reviewone'}; + &CheckName; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + $line =~ s/&/&/g; + $line =~ s/>/>/g; + $line =~ s/; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + $line =~ s/&/&/g; + $line =~ s/>/>/g; + $line =~ s/\n", + "

          $text{'5000'} ", + "$AccountName $text{'5001'}:", + "\n", + "

          \n", + "\n", + "\n", + "\n"; + unless ($NoBanners) { + print "\n"; + unless ($UserUploadDir && $RequireUpload && !$cryptword) { + print "\n"; + } + if (@zones) { + print ""; + unless ($NoBanners) { + print "\n"; + print ""; + } + print "\n"; + } + print "\n", + "

          $text{'5100'}:
          $text{'5101'}:
          $text{'5102'}:
          $text{'5103'}:", + ""; + if ($UserUploadDir && !(-s "$ADVadverts_dir/$subdir/$AccountName.txt")) { + print "
          $text{'5200'}"; + } + } + else { + print "
          $text{'5201'}"; + } + print "
          $text{'5104'}:"; + foreach $setzone (sort (@zones)) { + print "$setzone\n
          "; + } + print "$text{'5300'}"; + print "
          "; + $displayzone = "\+".$displayzone."\+"; + foreach $setzone (sort (@zones)) { + print "$setzone\n
          "; + } + print "$text{'5301'}"; + print "

          \n", + "

          \n", + "\n", + "\n"; + if ($AllowUserEdit && $INPUT{'newuser'}) { + print "\n"; + } + if ($cryptword) { + print "\n"; + } + print "

          \n"; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + print "

          "; + print "\n"; + } + print "

          \n"; + print "


          $text{'5400'}\n"; + print "

          \n", + "

          $text{'5401'}: \n", + "

          \n", + "\n"; + if ($cryptword) { + print "\n"; + } + print "

          \n"; + &Footer; +} + +sub NewUserPassword { + $AccountName = $INPUT{'reviewone'}; + &CheckName; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + ($pass) = $lines[0]; + unless ($INPUT{'password'} eq $pass) { + &ConfirmAdminPassword(2); + } + } + else { + &Header("$text{'9000'}","$text{'9050'}"); + print "

          $text{'9051'} "; + print ""$AccountName" $text{'9052'}\n"; + &Footer; + } + $lines[0] = $INPUT{'pass'}; + $INPUT{'password'} = $INPUT{'pass'}; + &ADVLockOpen (DISPLAY, "$subdir/$AccountName.dat","x"); + seek (DISPLAY,0,0); + foreach $key (0..3) { + print DISPLAY "$lines[$key]\n"; + } + truncate (DISPLAY,tell(DISPLAY)); + &ADVLockClose (DISPLAY, "$AccountName.dat"); + &reviewone; +} + +sub UploadBannerForm { + $AccountName = $INPUT{'reviewone'}; + &CheckName; + if ($UserUploadDir && (-s "$ADVadverts_dir/$subdir/$AccountName.txt")) { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + foreach $line (@lines) { + $line =~ s/&/&/g; + $line =~ s/>/>/g; + $line =~ s/$text{'5500'}\n"; + print "

          \n", + "

          $text{'5501'}: ", + "

          \n", + "\n"; + if ($cryptword) { + print "\n"; + } + print "

          \n"; + &Footer; + } + else { + &Header("$text{'9000'}","Upload Error!"); + print "

          Either uploading of banners isn't allowed, "; + print "or the account name provided is invalid!\n"; + &ADVDBMClose; + &ADVLockClose (DBMLIST, "dbmlist.txt"); + &Footer; + } +} + +sub UploadBanner { + $AccountName = $INPUT{'reviewone'}; + &CheckName; + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @lines = ; + close (DISPLAY); + chomp (@lines); + $pass = $lines[0]; + unless ($INPUT{'password'} eq $pass) { + &ConfirmAdminPassword(2); + } + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.txt"); + @lines = ; + close (DISPLAY); + chomp (@lines); + $image = $lines[4]; + } + else { + &Header("$text{'9000'}","$text{'9050'}"); + print "

          $text{'9051'} "; + print ""$AccountName" $text{'9052'}\n"; + &Footer; + } + if ($BannerType eq "GIF") { $bannername = "$AccountName.gif"; } + elsif ($BannerType eq "JPG") { $bannername = "$AccountName.jpg"; } + else { + &Header("$text{'9000'}","$text{'9060'}"); + print "

          $text{'9061'}\n"; + &Footer; + } + if (length($INPUT{'BannerFile'}) > ($MaxBannerSize*1024)) { + &Header("$text{'9000'}","$text{'9070'}"); + print "

          $text{'9071'} "; + print "$MaxBannerSize $text{'9072'} "; + print int((length($INPUT{'BannerFile'})/1024)+.5)," $text{'9073'}\n"; + &Footer; + } + unless (open (BANNER,">$UserUploadDir/$bannername")) { + &Header("$text{'9000'}","$text{'9080'}"); + print "

          $text{'9081'}\n"; + &Footer; + } + binmode BANNER; + print BANNER $INPUT{'BannerFile'}; + close (BANNER); + $image = "$UserUploadURL/$bannername"; + &ADVLockOpen (DISPLAY, "$subdir/$AccountName.txt","x"); + seek (DISPLAY,0,0); + $lines[4] = $image; + foreach $key (0..20) { + print DISPLAY "$lines[$key]\n"; + } + truncate (DISPLAY,tell(DISPLAY)); + &ADVLockClose (DISPLAY, "$AccountName.txt"); + $PresenceCheck = 0; + unless ($cryptword || !($RequireAdminApproval)) { + &ADVLockOpen (COUNT, "adlist.txt"); + @lines = ; + chomp (@lines); + seek(COUNT, 0, 0); + foreach $line (@lines) { + if ($line eq $AccountName) { $PresenceCheck = 1; } + unless (($line eq $AccountName) || (length($line) < 1)) { + print COUNT "$line\n"; + } + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT, "adlist.txt"); + } + if ($PresenceCheck) { + $PresenceCheck = 0; + &ADVLockOpen (COUNT, "adnew.txt"); + @lines = ; + chomp (@lines); + seek(COUNT, 0, 0); + foreach $line (@lines) { + if ($line eq $AccountName) { $PresenceCheck = 1; } + unless (($line eq $AccountName) || (length($line) < 1)) { + print COUNT "$line\n"; + } + } + unless ($PresenceCheck) { + print COUNT "$AccountName\n"; + &SendMail($email_address,"admin"); + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT, "adnew.txt"); + } + &reviewone; +} + +sub editgroup { + &ConfirmAdminPassword(1); + $AccountName = $INPUT{'editgroup'}; + &CheckName; + if (-s "$ADVadverts_dir/$AccountName.grp") { + open (DISPLAY, "<$ADVadverts_dir/$AccountName.grp"); + @lines = ; + close (DISPLAY); + chomp (@lines); + $grouppassword = $lines[0]; + $adverts = join(' ',@lines); + } + &Header("$text{'1000'}","$text{'1001'}"); + print "

          \n"; + print "

          Info for the "; + print "$AccountName Group:"; + print "\n"; + print "

          Select the adverts to be included in this group:\n"; + open (COUNT, "<$ADVadverts_dir/adlist.txt"); + @lines = ; + close (COUNT); + chomp (@lines); + @sortedlines = sort (@lines); + $size = @lines; + if ($size > 10) { $size = 10; } + print "

          \n"; + print "

          Password: \n"; + print "

          \n"; + print "\n"; + print "\n"; + if (-s "$ADVadverts_dir/$AccountName.grp") { + print "

          "; + print "\n"; + } + print "

          \n"; + &Footer; +} + +sub del { + $AccountName = $INPUT{'delad'}; + &CheckName; + unless (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + &Header("$text{'9000'}","$text{'9050'}"); + print "

          $text{'9051'} "; + print ""$AccountName" $text{'9052'}\n"; + &Footer; + } + &ConfirmUserPassword; + &Header("$text{'1000'}","$text{'1001'}"); + print "

          \n"; + print "\n"; + print "

          Are you sure you want to delete the "; + print "$AccountName account?\n"; + print "\n"; + if ($INPUT{'rejectionletter'}) { + print "\n"; + } + if ($cryptword) { + print "\n"; + } + print "\n"; + print "
          \n"; + &Footer; +} + +sub delgroup { + $AccountName = $INPUT{'delgroupname'}; + &CheckName; + unless (-s "$ADVadverts_dir/$AccountName.grp") { + &Header("$text{'9000'}","$text{'9050'}"); + print "

          $text{'9051'} "; + print ""$AccountName" $text{'9052'}\n"; + &Footer; + } + &ConfirmAdminPassword(1); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          \n"; + print "

          Are you sure you want to delete the "; + print "$AccountName group? "; + print "\n"; + print "\n"; + print "\n"; + print "
          \n"; + print "

          (Please note that deleting the group will "; + print "not delete or otherwise affect the adverts "; + print "themselves. Only the ability to view all their stats "; + print "on a single page will be gone!)\n"; + &Footer; +} + +sub newpass { + unless ($INPUT{'passad'} && ($INPUT{'passad'} eq $INPUT{'passad2'})) { + &Header("$text{'9000'}","$text{'9024'}"); + print "

          $text{'9025'}\n"; + &Footer; + } + open (PASSWORD, "<$ADVadverts_dir/adpassword.txt"); + $password = ; + close (PASSWORD); + chomp ($password); + if ($password) { + if ($INPUT{'password'}) { + $newpassword = crypt($INPUT{'password'}, "aa"); + } + else { + &Header("$text{'9000'}","$text{'9020'}"); + print "

          $text{'9021'}\n"; + &Footer; + } + unless ($newpassword eq $password) { + &Header("$text{'9000'}","$text{'9022'}"); + print "

          $text{'9023'}\n"; + &Footer; + } + } + $newpassword = crypt($INPUT{'passad'}, "aa"); + &ADVLockOpen (PASSWORD, "adpassword.txt"); + seek (PASSWORD,0,0); + print PASSWORD "$newpassword"; + truncate (PASSWORD,tell(PASSWORD)); + &ADVLockClose (PASSWORD,"adpassword.txt"); + &Header("$text{'1000'}","$text{'1001'}"); + print "

          Your administrative password "; + print "has been set.\n"; + $INPUT{'password'} = $INPUT{'passad'}; + &LinkBack; + &Footer; +} + +sub resetcount { + &ConfirmAdminPassword(1); + &ADVLockOpen (DBMLIST, "dbmlist.txt"); + if ($ADVlockerror) { &Error_DBM; } + else { + &ADVDBMOpen; + if ($ADVdbmerror) { &Error_DBM; } + else { + $DBMList{'adcount.txt'} = "1\n0\n$time"; + &ADVDBMClose; + } + } + &ADVLockClose (DBMLIST, "dbmlist.txt"); + if ($AdminDisplaySetup) { &defineview; } + else { + $INPUT{'whichtype'} = "pending established groups"; + $INPUT{'whichtime'} = "active expired disabled"; + $INPUT{'whichzone'} = ""; + &reviewall; + } +} + +sub editfinal { + $AccountName = $INPUT{'editad'}; + &CheckName; + unless (!(-s "$ADVadverts_dir/$subdir/$AccountName.txt") + && $AllowUserEdit && $INPUT{'newuser'}) { + &ConfirmUserPassword; + } + if (-s "$ADVadverts_dir/$subdir/$AccountName.txt") { + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.txt"); + @advertlines = ; + $image = $advertlines[4]; + close (DISPLAY); + chomp (@advertlines); + if ($cryptword) { + ($shown,$visits,$start,$displaycount,$clicksfrom) + = @advertlines[1,2,10,16,20]; + ($other,$displaycount) = split(/\|/, $displaycount); + ($clicksfrom,$other) = split(/\|/, $clicksfrom); + $comments = $INPUT{'comments'}; + } + else { + ($max,$shown,$visits,$dmy,$dmy,$height,$width, + $alt,$dmy,$text,$start,$weight,$zone, + $border,$target,$raw,$displayratio, + $dmy,$dmy,$displayzone,$clicksfrom) = @advertlines; + ($max,$maxtype) = split(/\|/, $max); + ($text,$texttype) = split(/\|/, $text); + ($displayratio,$displaycount) = split(/\|/, $displayratio); + ($clicksfrom,$clicksratio) = split(/\|/, $clicksfrom); + open (DISPLAY, "<$ADVadverts_dir/$subdir/$AccountName.dat"); + @advertlines = ; + close (DISPLAY); + chomp (@advertlines); + $comments = $advertlines[3]; + } + } + elsif (!($cryptword)) { + $maxtype = "E"; + $texttype = "B"; + $displayratio = $DefaultDisplayRatio; + $clicksratio = $DefaultClicksRatio; + $target = $DefaultLinkAttribute; + $weight = $DefaultWeight; + $border = $DefaultBorder; + if ($NoBanners) { + $INPUT{'url'} = ""; + $INPUT{'image'} = ""; + $INPUT{'zone'} = ""; + } + } + $INPUT{'email'} =~ s/\s//g; + unless ($INPUT{'email'} =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)|,|;|\// + || $INPUT{'email'} !~ + /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,6}|[0-9]{1,3})(\]?)$/) + { + $email = "$INPUT{'email'}"; + } + $INPUT{'url'} =~ s/\s//g; + unless ($INPUT{'url'} =~ /(\.\.)|(^\.)|(\/\/\.)/ || + $INPUT{'url'} !~ /(.*\:\/\/.*\..*|mailto:.*@.*)/) { + $INPUT{'url'} =~ s/\|/%7c/g; + $url = $INPUT{'url'}; + } + if ($UserUploadDir && $RequireUpload && !$cryptword) { $INPUT{'image'} = ""; } + else { $image = ""; } + @image = split(/\cM|\n/,$INPUT{'image'}); + foreach $fauximage (@image) { + $fauximage =~ s/\s//g; + unless ($fauximage =~ /(\.\.)|(^\.)|(\/\/\.)/ + || $fauximage !~ /.*\:\/\/.*\..*/ + || $fauximage =~ /script:/) { + $fauximage =~ s/\|/%7c/g; + $image = $image.$fauximage."|"; + } + } + chop ($image); + $pass = $INPUT{'pass'}; + if ($cryptword) { + $displayratio = $INPUT{'displayratio'}; + if ($displayratio < 1) { $displayratio = 0; } + $clicksratio = $INPUT{'clicksratio'}; + if ($clicksratio < 1) { $clicksratio = 0; } + $weight = int($INPUT{'weight'}); + } + if ($INPUT{'zone'}) { + $zone = $INPUT{'zone'}; + $zone =~ s/^\s+//; + $zone =~ s/\s+$//; + $zone =~ s/\s+/ /g; + } + if ($INPUT{'displayzone'}) { + $displayzone = $INPUT{'displayzone'}; + $displayzone =~ s/^\s+//; + $displayzone =~ s/\s+$//; + $displayzone =~ s/\s+/\+/g; + } + if ($cryptword) { + if ($INPUT{'purchtype'} eq "D") { + if ($max) { ($mday,$mon,$year) = (localtime($max+($ADVHourOffset*3600)))[3,4,5]; } + else { ($mday,$mon,$year) = (localtime($time+($ADVHourOffset*3600)))[3,4,5]; } + $year += 1900; + unless ($INPUT{'EndDateA'}) { $INPUT{'EndDateA'} = $mday; $INPUT{'EndDateB'} = $mon; } + if ($INPUT{'EndDateC'} < 1990) { $INPUT{'EndDateC'} = $year; } + $max = &rangedate($INPUT{'EndDateB'}+1,$INPUT{'EndDateA'}+1,$INPUT{'EndDateC'}-1900); + $max -= 1; + } + else { + $INPUT{'purch'} =~ s/[^-\d]//g; + $max = $INPUT{'purch'}; + } + $maxtype = $INPUT{'purchtype'}; + if (($max < 0) && ($maxtype ne "E")) { $max = 0; } + if ($start) { ($mday,$mon,$year) = (localtime($start+($ADVHourOffset*3600)))[3,4,5]; } + else { ($mday,$mon,$year) = (localtime($time+($ADVHourOffset*3600)))[3,4,5]; } + $year += 1900; + unless ($INPUT{'StartDateA'}) { $INPUT{'StartDateA'} = $mday; $INPUT{'StartDateB'} = $mon; } + if ($INPUT{'StartDateC'} < 1990) { $INPUT{'StartDateC'} = $year; } + $start = &rangedate($INPUT{'StartDateB'}+1,$INPUT{'StartDateA'},$INPUT{'StartDateC'}-1900); + $height = int($INPUT{'height'}); + $width = int($INPUT{'width'}); + $alt = $INPUT{'alt'}; + $INPUT{'text'} =~ s/^\s+//; + $INPUT{'text'} =~ s/\s+$//; + $INPUT{'text'} =~ s/\s+/ /g; + $text = $INPUT{'text'}; + $texttype = $INPUT{'texttype'}; + $border = int($INPUT{'border'}); + $target = $INPUT{'target'}; + $INPUT{'raw'} =~ s/(\cM|\n)+//g; + $raw = $INPUT{'raw'}; + } + unless ($pass) { + &Header("$text{'9000'}","$text{'9100'}"); + print "

          $text{'9101'}\n"; + &Footer; + } + if ((($maxtype eq "C") || ($maxtype eq "D")) && ($displayratio || $clicksratio)) { + &Header("$text{'9000'}","$text{'9110'}"); + print "

          $text{'9111'}\n"; + &Footer; + } + $PresenceCheck = 0; + if (-s "$ADVadverts_dir/adnew.txt") { + &ADVLockOpen (COUNT, "adnew.txt"); + @lines = ; + chomp (@lines); + seek(COUNT, 0, 0); + foreach $line (@lines) { + if ($line eq $AccountName) { $PresenceCheck = 1; } + unless (($line eq $AccountName) || (length($line) < 1)) { + print COUNT "$line\n"; + } + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT, "adnew.txt"); + } + if (-s "$ADVadverts_dir/adlist.txt") { + &ADVLockOpen (COUNT, "adlist.txt"); + @lines = ; + chomp (@lines); + seek(COUNT, 0, 0); + foreach $line (@lines) { + if ($line eq $AccountName) { $PresenceCheck = 1; } + unless (($line eq $AccountName) || (length($line) < 1)) { + print COUNT "$line\n"; + } + } + truncate (COUNT, tell(COUNT)); + &ADVLockClose (COUNT, "adlist.txt"); + } + if ($INPUT{'resetadvert'} + || (!$PresenceCheck && !$shown)) { + $shown = 0; + $visits = 0; + unless ($start > $time) { $start = $time; } + $displaycount = 0; + $clicksfrom = 0; + unlink ("$ADVadverts_dir/$subdir/$AccountName.log"); + } + if ($maxtype eq "N") { $max = 0; } + &ADVLockOpen (DISPLAY, "$subdir/$AccountName.txt","x"); + seek (DISPLAY,0,0); + print DISPLAY "$max|$maxtype\n"; + print DISPLAY "$shown\n"; + print DISPLAY "$visits\n"; + print DISPLAY "$url\n"; + print DISPLAY "$image\n"; + print DISPLAY "$height\n"; + print DISPLAY "$width\n"; + print DISPLAY "$alt\n\n"; + print DISPLAY "$text|$texttype\n"; + print DISPLAY "$start\n"; + print DISPLAY "$weight\n"; + print DISPLAY " $zone \n"; + print DISPLAY "$border\n"; + print DISPLAY "$target\n"; + print DISPLAY "$raw\n"; + print DISPLAY "$displayratio|$displaycount\n\n\n"; + print DISPLAY "$displayzone\n"; + print DISPLAY "$clicksfrom|$clicksratio\n"; + if ((@advertlines > 21) && !($INPUT{'resetadvert'})) { + foreach $key (21..(@advertlines-1)) { + print DISPLAY "$advertlines[$key]\n"; + } + } + truncate (DISPLAY,tell(DISPLAY)); + &ADVLockClose (DISPLAY, "AccountName.txt"); + &ADVLockOpen (DISPLAY, "$subdir/$AccountName.dat","x"); + seek (DISPLAY,0,0); + print DISPLAY "$pass\n"; + print DISPLAY "$INPUT{'username'}\n"; + print DISPLAY "$email\n"; + print DISPLAY "$comments\n"; + truncate (DISPLAY,tell(DISPLAY)); + &ADVLockClose (DISPLAY, "AccountName.dat"); + &ADVLockOpen (DBMLIST, "dbmlist.txt"); + if ($ADVlockerror) { &Error_DBM; } + else { + &ADVDBMOpen; + if ($ADVdbmerror) { &Error_DBM; } + else { + if ($image) { $image = "X"; } + if ($raw =~ /