Index: /branches/mt4.11/mt-wizard.cgi =================================================================== --- /branches/mt4.11/mt-wizard.cgi (revision 1174) +++ /branches/mt4.11/mt-wizard.cgi (revision 1174) @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# This program is distributed under the terms of the +# GNU General Public License, version 2. +# +# $Id$ + +use strict; +use lib $ENV{MT_HOME} ? "$ENV{MT_HOME}/lib" : 'lib'; +use MT::Bootstrap App => 'MT::App::Wizard'; Index: /branches/mt4.11/mt-atom.cgi =================================================================== --- /branches/mt4.11/mt-atom.cgi (revision 1174) +++ /branches/mt4.11/mt-atom.cgi (revision 1174) @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# This program is distributed under the terms of the +# GNU General Public License, version 2. +# +# $Id$ + +use strict; +use lib $ENV{MT_HOME} ? "$ENV{MT_HOME}/lib" : 'lib'; +use MT::Bootstrap App => 'MT::AtomServer'; Index: /branches/mt4.11/index.html.es =================================================================== --- /branches/mt4.11/index.html.es (revision 1278) +++ /branches/mt4.11/index.html.es (revision 1278) @@ -0,0 +1,100 @@ + + + + + + + + + + Movable Type Publishing Platform + + + + + + +
+
+ +

Movable Type

+ +

¡Bienvenido a Movable Type, la mejor plataforma de publicación de blogs.

+ + + +

¿Instalando?

+ +

Si acaba de empezar con Movable Type, quizás desee consultar la sección de instalación/actualización de la documentación de Movable Type y ver la comprobación del sistema de Movable Type para segurarse de que su sistema tiene todo lo necesario.

+
+
+ + + Index: /branches/mt4.11/mt.cgi =================================================================== --- /branches/mt4.11/mt.cgi (revision 1174) +++ /branches/mt4.11/mt.cgi (revision 1174) @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# This program is distributed under the terms of the +# GNU General Public License, version 2. +# +# $Id$ + +use strict; +use lib $ENV{MT_HOME} ? "$ENV{MT_HOME}/lib" : 'lib'; +use MT::Bootstrap App => 'MT::App::CMS'; Index: /branches/mt4.11/mt-feed.cgi =================================================================== --- /branches/mt4.11/mt-feed.cgi (revision 1174) +++ /branches/mt4.11/mt-feed.cgi (revision 1174) @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Movable Type (r) Open Source (C) 2005-2008 Six Apart, Ltd. +# This program is distributed under the terms of the +# GNU General Public License, version 2. +# +# $Id$ + +use strict; +use lib $ENV{MT_HOME} ? "$ENV{MT_HOME}/lib" : 'lib'; +use MT::Bootstrap App => 'MT::App::ActivityFeeds'; Index: /branches/mt4.11/schemas/sqlmangle =================================================================== --- /branches/mt4.11/schemas/sqlmangle (revision 1098) +++ /branches/mt4.11/schemas/sqlmangle (revision 1098) @@ -0,0 +1,197 @@ +#!/usr/bin/perl + +# Simple perl script to take portable SQL +# and generate database specific DDL + +use strict; + +sub usage { + return <$outputfile") || die "Cannot open '$outputfile': $!\n"; + select(OUTPUT); +} + +# put inputfile back in ARGV so we can just use <> +unshift(@ARGV, $inputfile); + + +sub to_sqlite { + s/BOOLEAN/SMALLINT/g; + s/TINYINT/SMALLINT/g; + s/MEDIUMTEXT/TEXT/g; + s/SERIAL//g; +} + +sub to_oracle { + s/TEXT/CLOB/g; + s/VARCHAR/VARCHAR2/g; + s/TINYINT/NUMBER(3,0)/g; + s/SMALLINT/NUMBER(6,0)/g; + s/INTEGER/NUMBER(20,0)/g; + s/TIMESTAMP/DATE/g; + s/SERIAL//g; + if (/^CREATE TABLE (\w+) \(/) { + $_ .= < 17) { + # get rid of vowels + $index_name =~ s/[aeiou]//g; + if (length($index_name) > 17) { + # umm, truncate it? + $index_name = substr($index_name, 0,17); + } + $index_name =~ s/_$//; + + s/CREATE INDEX ([a-z0-9_]+)/CREATE INDEX $index_name/; + } + } + # handle 30 character column name limit, barf... + if (m/^\s+([a-z_]+)\s+(VARCHAR|TEXT|CHAR|INTEGER)/) { + if (length($1) > 30) { + # At this time we hack this to reduce _display_ to _disp_ + # new sql code with long column names will have to be dealt with + unless (s/_display_/_disp_/) { + die "Found long column name $1 that we can't deal with\n"; + } + } + } + +} + +# Convert to MySQL DDL format + +sub to_mysql { + s/(\s)(?:TEXT|VARCHAR)(\s*)\((\d+)\)/ + my($space1, $space2, $textlen) = ($1, $2, $3); + + my $type; + if ($textlen < 256) { + $type = 'VARCHAR'; + } elsif ($textlen < 65536) { + $type = 'TEXT'; + } elsif ($textlen < 16777216) { + $type = 'MEDIUMTEXT'; + } else { + $type = 'LONGTEXT'; + } + $space1 . $type . $space2 . '(' . $textlen . ')'; + /ge; + s/(\s)BLOB(\s*)\((\d+)\)/ + my($space1, $space2, $bloblen) = ($1, $2, $3); + my $type; + if ($bloblen < 256) { + $type = 'TINYBLOB'; + } elsif ($bloblen < 65536) { + $type = 'MEDIUMBLOB'; + } elsif ($bloblen < 16777216) { + $type = 'LONGBLOB'; + } + $space1 . $type . $space2 . '(' . $bloblen . ')'; + /ge; + + # default TEXT/BLOB limit is 65535 + #s/(\s)TEXT/$1MEDIUMTEXT/g; + #s/(\s)BLOB/$1MEDIUMBLOB/g; + + # TIMESTAMP should become DATETIME, because we don't want it to + # auto-update (the drivers will handle that). + s/_created_on\s+TIMESTAMP/_created_on DATETIME/g; # except for the modified_on fields + s/blog_children_modified_on\s+TIMESTAMP/blog_children_modified_on DATETIME/g; # except for the modified_on fields + + # handle autoincrement + s/SERIAL/AUTO_INCREMENT/; +} + +my $conv_func = 'to_' . $dbtarget; + +local $/ = ';'; + +while (<>) { + s/^\-.*$//mg; ## Strip comments on their own lines. + s/^\s*//; + s/\s*$//; + # can't hurt, saves keystrokes + s/PRIMARY KEY/PRIMARY KEY NOT NULL/; + no strict 'refs'; + &{$conv_func}; + use strict 'refs'; + print $_, "\n"; +} + +# post stage.. Write out sequences if needed. Index: /branches/mt4.11/schemas/sqlite.dump =================================================================== --- /branches/mt4.11/schemas/sqlite.dump (revision 1098) +++ /branches/mt4.11/schemas/sqlite.dump (revision 1098) @@ -0,0 +1,317 @@ +create table mt_author ( + author_id integer not null primary key, + author_name varchar(50) not null, + author_type smallint not null, + author_nickname varchar(50), + author_password varchar(60) not null, + author_email varchar(75) not null, + author_url varchar(255), + author_can_create_blog boolean, + author_can_view_log boolean, + author_hint varchar(75), + author_created_by integer, + author_public_key text, + author_preferred_language varchar(50), + author_remote_auth_username varchar(50), + author_remote_auth_token varchar(50), + unique (author_name, author_type) +); +create index mt_author_email on mt_author (author_email); + +create table mt_blog ( + blog_id integer not null primary key, + blog_name varchar(255) not null, + blog_description text, + blog_site_path varchar(255), + blog_site_url varchar(255), + blog_archive_path varchar(255), + blog_archive_url varchar(255), + blog_archive_type varchar(255), + blog_archive_type_preferred varchar(25), + blog_days_on_index smallint, + blog_entries_on_index smallint, + blog_language varchar(5), + blog_file_extension varchar(10), + blog_email_new_comments boolean, + blog_email_new_pings boolean, + blog_allow_comment_html boolean, + blog_autolink_urls boolean, + blog_sort_order_posts varchar(8), + blog_sort_order_comments varchar(8), + blog_allow_comments_default boolean, + blog_allow_pings_default boolean, + blog_server_offset float, + blog_convert_paras varchar(30), + blog_convert_paras_comments varchar(30), + blog_status_default smallint, + blog_allow_anon_comments boolean, + blog_allow_unreg_comments smallint, + blog_allow_reg_comments smallint, + blog_allow_pings smallint, + blog_moderate_unreg_comments smallint, + blog_require_comment_emails smallint, + blog_manual_approve_commenters smallint, + blog_moderate_pings smallint, + blog_words_in_excerpt smallint, + blog_ping_weblogs boolean, + blog_ping_blogs boolean, + blog_ping_technorati boolean, + blog_ping_others text, + blog_mt_update_key varchar(30), + blog_autodiscover_links boolean, + blog_welcome_msg text, + blog_junk_score_threshold float, + blog_junk_folder_expiry integer, + blog_old_style_archive_links smallint, + blog_archive_tmpl_monthly varchar(255), + blog_archive_tmpl_weekly varchar(255), + blog_archive_tmpl_daily varchar(255), + blog_archive_tmpl_individual varchar(255), + blog_archive_tmpl_category varchar(255), + blog_google_api_key varchar(32), + blog_sanitize_spec varchar(255), + blog_cc_license varchar(255), + blog_is_dynamic boolean, + blog_remote_auth_token varchar(50), + blog_children_modified_on datetime, + blog_custom_dynamic_templates varchar(25) +); +create index mt_blog_name on mt_blog (blog_name); + +create table mt_category ( + category_id integer not null primary key, + category_blog_id integer not null, + category_allow_pings boolean, + category_label varchar(100) not null, + category_description text, + category_author_id integer, + category_ping_urls text, + category_parent integer not null default 0, + unique (category_blog_id, category_label) +); + +create table mt_comment ( + comment_id integer not null primary key, + comment_blog_id integer not null, + comment_entry_id integer not null, + comment_ip varchar(16), + comment_author varchar(100), + comment_email varchar(75), + comment_url varchar(255), + comment_commenter_id integer, + comment_visible smallint, + comment_text text, + comment_junk_status smallint not null default 0, + comment_junk_log text, + comment_junk_score float, + comment_created_on timestamp not null, + comment_modified_on timestamp not null, + comment_last_moved_on timestamp not null, + comment_created_by integer, + comment_modified_by integer +); +create index mt_comment_created_on on mt_comment (comment_created_on); +create index mt_comment_entry_id on mt_comment (comment_entry_id); +create index mt_comment_blog_id on mt_comment (comment_blog_id); + +create table mt_entry ( + entry_id integer not null primary key, + entry_blog_id integer not null, + entry_status smallint not null, + entry_author_id integer not null, + entry_allow_comments boolean, + entry_allow_pings boolean, + entry_convert_breaks varchar(30), + entry_category_id integer, + entry_title varchar(255), + entry_excerpt text, + entry_text text, + entry_text_more text, + entry_to_ping_urls text, + entry_pinged_urls text, + entry_keywords text, + entry_tangent_cache text, + entry_week_number smallint, + entry_created_on timestamp not null, + entry_modified_on timestamp not null, + entry_basename varchar(50), + entry_created_by integer, + entry_modified_by integer +); +create index mt_entry_blog_id on mt_entry (entry_blog_id); +create index mt_entry_status on mt_entry (entry_status); +create index mt_entry_author_id on mt_entry (entry_author_id); +create index mt_entry_created_on on mt_entry (entry_created_on); +create index mt_entry_basename on mt_entry (entry_basename); + +create table mt_ipbanlist ( + ipbanlist_id integer not null primary key, + ipbanlist_blog_id integer not null, + ipbanlist_ip varchar(15) not null, + ipbanlist_created_on timestamp not null, + ipbanlist_modified_on timestamp not null, + ipbanlist_created_by integer, + ipbanlist_modified_by integer +); +create index mt_ipbanlist_blog_id on mt_ipbanlist (ipbanlist_blog_id); +create index mt_ipbanlist_ip on mt_ipbanlist (ipbanlist_ip); + +create table mt_log ( + log_id integer not null primary key, + log_message varchar(255), + log_ip varchar(16), + log_blog_id integer default 0, + log_created_on timestamp not null, + log_modified_on timestamp not null, + log_created_by integer, + log_modified_by integer +); +create index mt_log_created_on on mt_log (log_created_on); + +create table mt_notification ( + notification_id integer not null primary key, + notification_blog_id integer not null, + notification_name varchar(50), + notification_email varchar(75), + notification_url varchar(255), + notification_created_on timestamp not null, + notification_modified_on timestamp not null, + notification_created_by integer, + notification_modified_by integer +); +create index mt_notification_blog_id on mt_notification (notification_blog_id); + +create table mt_permission ( + permission_id integer not null primary key, + permission_author_id integer not null, + permission_blog_id integer not null, + permission_role_mask smallint, + permission_entry_prefs varchar(255), + unique (permission_blog_id, permission_author_id) +); + +create table mt_placement ( + placement_id integer not null primary key, + placement_entry_id integer not null, + placement_blog_id integer not null, + placement_category_id integer not null, + placement_is_primary boolean not null +); +create index mt_placement_entry_id on mt_placement (placement_entry_id); +create index mt_placement_category_id on mt_placement (placement_category_id); +create index mt_placement_is_primary on mt_placement (placement_is_primary); + +create table mt_plugindata ( + plugindata_id integer not null primary key, + plugindata_plugin varchar(50) not null, + plugindata_key varchar(255) not null, + plugindata_data text +); +create index mt_plugindata_plugin on mt_plugindata (plugindata_plugin); +create index mt_plugindata_key on mt_plugindata (plugindata_key); + +create table mt_template ( + template_id integer not null primary key, + template_blog_id integer not null, + template_name varchar(50) not null, + template_type varchar(25) not null, + template_outfile varchar(255), + template_rebuild_me boolean, + template_text text, + template_linked_file varchar(255), + template_linked_file_mtime varchar(10), + template_linked_file_size integer, + template_created_on datetime not null, + template_modified_on timestamp not null, + template_created_by integer, + template_modified_by integer, + template_build_dynamic boolean not null default 0, + unique (template_blog_id, template_name) +); +create index mt_template_type on mt_template (template_type); + +create table mt_templatemap ( + templatemap_id integer not null primary key, + templatemap_blog_id integer not null, + templatemap_template_id integer not null, + templatemap_archive_type varchar(25) not null, + templatemap_file_template varchar(255), + templatemap_is_preferred boolean not null +); +create index mt_templatemap_blog_id on mt_templatemap (templatemap_blog_id); +create index mt_templatemap_template_id on mt_templatemap (templatemap_template_id); +create index mt_templatemap_archive_type on mt_templatemap (templatemap_archive_type); +create index mt_templatemap_is_preferred on mt_templatemap (templatemap_is_preferred); + +create table mt_trackback ( + trackback_id integer not null primary key, + trackback_blog_id integer not null, + trackback_title varchar(255), + trackback_description text, + trackback_rss_file varchar(255), + trackback_url varchar(255), + trackback_entry_id integer not null, + trackback_category_id integer not null, + trackback_passphrase varchar(30), + trackback_is_disabled boolean, + trackback_created_on timestamp not null, + trackback_modified_on timestamp not null, + trackback_created_by integer, + trackback_modified_by integer +); +create index mt_trackback_blog_id on mt_trackback (trackback_blog_id); +create index mt_trackback_entry_id on mt_trackback (trackback_entry_id); +create index mt_trackback_category_id on mt_trackback (trackback_category_id); +create index mt_trackback_created_on on mt_trackback (trackback_created_on); + +create table mt_tbping ( + tbping_id integer not null primary key, + tbping_blog_id integer not null, + tbping_tb_id integer not null, + tbping_title varchar(255), + tbping_excerpt text, + tbping_source_url varchar(255), + tbping_ip varchar(15) not null, + tbping_blog_name varchar(255), + tbping_visible smallint, + tbping_junk_status tinyint not null default 0, + tbping_junk_log text, + tbping_junk_score float, + tbping_created_on timestamp not null, + tbping_modified_on timestamp not null, + tbping_last_moved_on timestamp not null, + tbping_created_by integer, + tbping_modified_by integer +); +create index mt_tbping_blog_id on mt_tbping (tbping_blog_id); +create index mt_tbping_tb_id on mt_tbping (tbping_tb_id); +create index mt_tbping_ip on mt_tbping (tbping_ip); +create index mt_tbping_created_on on mt_tbping (tbping_created_on); + +create table mt_session ( + session_id varchar(80) not null primary key, + session_data text, + session_email varchar(255), + session_name varchar(255), + session_start integer not null, + session_kind varchar(2) +); +create index mt_session_start on mt_session (session_start); + +create table mt_fileinfo ( + fileinfo_id INTEGER PRIMARY KEY, + fileinfo_blog_id integer not null, + fileinfo_entry_id integer, + fileinfo_url varchar(255), + fileinfo_file_path text, + fileinfo_template_id integer, + fileinfo_templatemap_id integer, + fileinfo_archive_type varchar(255), + fileinfo_category_id integer, + fileinfo_startdate varchar(80), + fileinfo_virtual tinyint +); +create index mt_fileinfo_blog_id on mt_fileinfo (fileinfo_blog_id); +create index mt_fileinfo_entry_id on mt_fileinfo (fileinfo_entry_id); +create index mt_fileinfo_url on mt_fileinfo (fileinfo_url); + Index: /branches/mt4.11/schemas/mysql.dump =================================================================== --- /branches/mt4.11/schemas/mysql.dump (revision 1098) +++ /branches/mt4.11/schemas/mysql.dump (revision 1098) @@ -0,0 +1,323 @@ +-- $Id$ + +create table mt_author ( + author_id integer not null auto_increment primary key, + author_name varchar(50) not null, + author_type tinyint not null, + author_nickname varchar(50), + author_password varchar(60) not null, + author_email varchar(75) not null, + author_url varchar(255), + author_can_create_blog tinyint, + author_can_view_log tinyint, + author_hint varchar(75), + author_created_by integer, + author_public_key text, + author_preferred_language varchar(50), + author_remote_auth_username varchar(50), + author_remote_auth_token varchar(50), + unique (author_name, author_type), + index (author_email) +); + +create table mt_blog ( + blog_id integer not null auto_increment primary key, + blog_name varchar(255) not null, + blog_description text, + blog_site_path varchar(255), + blog_site_url varchar(255), + blog_archive_path varchar(255), + blog_archive_url varchar(255), + blog_archive_type varchar(255), + blog_archive_type_preferred varchar(25), + blog_days_on_index smallint, + blog_entries_on_index smallint, + blog_language varchar(5), + blog_suspicious_url_count integer, + blog_suspicious_entry_age integer, + blog_junk_folder_expiry integer, + blog_junk_score_threshold float, + blog_file_extension varchar(10), + blog_email_new_comments tinyint, + blog_email_new_pings tinyint, + blog_allow_comment_html tinyint, + blog_autolink_urls tinyint, + blog_sort_order_posts varchar(8), + blog_sort_order_comments varchar(8), + blog_allow_comments_default tinyint, + blog_allow_pings_default tinyint, + blog_server_offset float, + blog_convert_paras varchar(30), + blog_convert_paras_comments varchar(30), + blog_status_default tinyint, + blog_allow_anon_comments tinyint, + blog_allow_reg_comments tinyint, + blog_allow_unreg_comments tinyint, + blog_allow_pings tinyint, + blog_moderate_unreg_comments tinyint, + blog_require_comment_emails tinyint, + blog_manual_approve_commenters tinyint, + blog_moderate_pings tinyint, + blog_words_in_excerpt smallint, + blog_ping_technorati tinyint, + blog_ping_weblogs tinyint, + blog_ping_blogs tinyint, + blog_ping_others text, + blog_mt_update_key varchar(30), + blog_autodiscover_links tinyint, + blog_welcome_msg text, + blog_old_style_archive_links tinyint, + blog_archive_tmpl_monthly varchar(255), + blog_archive_tmpl_weekly varchar(255), + blog_archive_tmpl_daily varchar(255), + blog_archive_tmpl_individual varchar(255), + blog_archive_tmpl_category varchar(255), + blog_google_api_key varchar(32), + blog_sanitize_spec varchar(255), + blog_cc_license varchar(255), + blog_is_dynamic tinyint, + blog_remote_auth_token varchar(50), + blog_children_modified_on datetime, + blog_custom_dynamic_templates varchar(25), + index (blog_name) +); + +create table mt_category ( + category_id integer not null auto_increment primary key, + category_blog_id integer not null, + category_allow_pings tinyint, + category_label varchar(100) not null, + category_description text, + category_author_id integer, + category_ping_urls text, + category_parent integer, +); + +create table mt_comment ( + comment_id integer not null auto_increment primary key, + comment_blog_id integer not null, + comment_entry_id integer not null, + comment_ip varchar(16), + comment_author varchar(100), + comment_email varchar(75), + comment_url varchar(255), + comment_commenter_id integer, + comment_visible tinyint, + comment_junk_status tinyint not null default 0, + comment_junk_log text, + comment_junk_score float, + comment_text text, + comment_last_moved_on timestamp not null, + comment_created_on datetime not null, + comment_modified_on timestamp not null, + comment_created_by integer, + comment_modified_by integer, + index (comment_created_on), + index (comment_entry_id), + index (comment_blog_id), + index (comment_junk_status) +); + +create table mt_entry ( + entry_id integer not null auto_increment primary key, + entry_blog_id integer not null, + entry_status tinyint not null, + entry_author_id integer not null, + entry_allow_comments tinyint, + entry_allow_pings tinyint, + entry_convert_breaks varchar(30), + entry_category_id integer, + entry_title varchar(255), + entry_excerpt text, + entry_text text, + entry_text_more text, + entry_to_ping_urls text, + entry_pinged_urls text, + entry_keywords text, + entry_tangent_cache text, + entry_created_on datetime not null, + entry_modified_on timestamp not null, + entry_created_by integer, + entry_modified_by integer, + entry_basename varchar(50) not null, + entry_week_number integer, + index (entry_blog_id), + index (entry_status), + index (entry_author_id), + index (entry_created_on), + index (entry_basename), + index (entry_week_number) +); + +create table mt_ipbanlist ( + ipbanlist_id integer not null auto_increment primary key, + ipbanlist_blog_id integer not null, + ipbanlist_ip varchar(15) not null, + ipbanlist_created_on datetime not null, + ipbanlist_modified_on timestamp not null, + ipbanlist_created_by integer, + ipbanlist_modified_by integer, + index (ipbanlist_blog_id), + index (ipbanlist_ip) +); + +create table mt_log ( + log_id integer not null auto_increment primary key, + log_message varchar(255), + log_ip varchar(16), + log_blog_id integer default 0 not null, + log_created_on datetime not null, + log_modified_on timestamp not null, + log_created_by integer, + log_modified_by integer, + index (log_created_on) +); + +create table mt_notification ( + notification_id integer not null auto_increment primary key, + notification_blog_id integer not null, + notification_name varchar(50), + notification_email varchar(75), + notification_url varchar(255), + notification_created_on datetime not null, + notification_modified_on timestamp not null, + notification_created_by integer, + notification_modified_by integer, + index (notification_blog_id) +); + +create table mt_permission ( + permission_id integer not null auto_increment primary key, + permission_author_id integer not null, + permission_blog_id integer not null, + permission_role_mask smallint, + permission_entry_prefs varchar(255), + unique (permission_blog_id, permission_author_id) +); + +create table mt_placement ( + placement_id integer not null auto_increment primary key, + placement_entry_id integer not null, + placement_blog_id integer not null, + placement_category_id integer not null, + placement_is_primary tinyint not null, + index (placement_entry_id), + index (placement_category_id), + index (placement_is_primary) +); + +create table mt_plugindata ( + plugindata_id integer not null auto_increment primary key, + plugindata_plugin varchar(50) not null, + plugindata_key varchar(255) not null, + plugindata_data mediumtext, + index (plugindata_plugin), + index (plugindata_key) +); + +create table mt_template ( + template_id integer not null auto_increment primary key, + template_blog_id integer not null, + template_name varchar(50) not null, + template_type varchar(25) not null, + template_outfile varchar(255), + template_rebuild_me tinyint default 1, + template_text text, + template_linked_file varchar(255), + template_linked_file_mtime varchar(10), + template_linked_file_size mediumint, + template_created_on datetime not null, + template_modified_on timestamp not null, + template_created_by integer, + template_modified_by integer, + template_build_dynamic tinyint, + unique (template_blog_id, template_name), + index (template_type) +); + +create table mt_templatemap ( + templatemap_id integer not null auto_increment primary key, + templatemap_blog_id integer not null, + templatemap_template_id integer not null, + templatemap_archive_type varchar(25) not null, + templatemap_file_template varchar(255), + templatemap_is_preferred tinyint not null, + index (templatemap_blog_id), + index (templatemap_template_id), + index (templatemap_archive_type), + index (templatemap_is_preferred) +); + +create table mt_trackback ( + trackback_id integer not null auto_increment primary key, + trackback_blog_id integer not null, + trackback_title varchar(255), + trackback_description text, + trackback_rss_file varchar(255), + trackback_url varchar(255), + trackback_entry_id integer not null, + trackback_category_id integer not null, + trackback_passphrase varchar(30), + trackback_is_disabled tinyint default 0, + trackback_created_on datetime not null, + trackback_modified_on timestamp not null, + trackback_created_by integer, + trackback_modified_by integer, + index (trackback_blog_id), + index (trackback_entry_id), + index (trackback_category_id), + index (trackback_created_on) +); + +create table mt_tbping ( + tbping_id integer not null auto_increment primary key, + tbping_blog_id integer not null, + tbping_tb_id integer not null, + tbping_title varchar(255), + tbping_excerpt text, + tbping_source_url varchar(255), + tbping_ip varchar(15) not null, + tbping_blog_name varchar(255), + tbping_visible tinyint, + tbping_junk_log text, + tbping_junk_status tinyint not null default 0, + tbping_junk_score float, + tbping_last_moved_on timestamp not null, + tbping_created_on datetime not null, + tbping_modified_on timestamp not null, + tbping_created_by integer, + tbping_modified_by integer, + index (tbping_blog_id), + index (tbping_tb_id), + index (tbping_ip), + index (tbping_junk_status), + index (tbping_created_on), + index (tbping_last_moved_on) +); + +create table mt_session ( + session_id varchar(80) not null primary key, + session_data text, + session_email varchar(255), + session_name varchar(255), + session_start int not null, + session_kind varchar(2), + index (session_start) +); + +create table mt_fileinfo ( + fileinfo_id integer primary key auto_increment, + fileinfo_blog_id integer not null, + fileinfo_entry_id integer, + fileinfo_url varchar(255), + fileinfo_file_path text, + fileinfo_template_id integer, + fileinfo_templatemap_id integer, + fileinfo_archive_type varchar(255), + fileinfo_category_id integer, + fileinfo_startdate varchar(80), + fileinfo_virtual tinyint, + index(fileinfo_blog_id), + index(fileinfo_entry_id), + index(fileinfo_url) +); Index: /branches/mt4.11/schemas/postgres.dump =================================================================== --- /branches/mt4.11/schemas/postgres.dump (revision 1098) +++ /branches/mt4.11/schemas/postgres.dump (revision 1098) @@ -0,0 +1,333 @@ +create table mt_author ( + author_id integer primary key not null, + author_name varchar(50) not null, + author_type smallint not null, + author_nickname varchar(50), + author_password varchar(60) not null, + author_email varchar(75) not null, + author_url varchar(255), + author_can_create_blog smallint, + author_can_view_log smallint, + author_hint varchar(75), + author_created_by integer, + author_public_key text, + author_preferred_language varchar(50), + author_remote_auth_username varchar(50), + author_remote_auth_token varchar(50), + unique (author_name, author_type) +); +create sequence mt_author_id; +create index mt_author_email on mt_author (author_email); + +create table mt_blog ( + blog_id integer primary key not null, + blog_name varchar(255) not null, + blog_description text, + blog_site_path varchar(255), + blog_site_url varchar(255), + blog_archive_path varchar(255), + blog_archive_url varchar(255), + blog_archive_type varchar(255), + blog_archive_type_preferred varchar(25), + blog_days_on_index integer, + blog_entries_on_index integer, + blog_language varchar(5), + blog_file_extension varchar(10), + blog_email_new_comments smallint, + blog_email_new_pings smallint, + blog_allow_comment_html smallint, + blog_autolink_urls smallint, + blog_sort_order_posts varchar(8), + blog_sort_order_comments varchar(8), + blog_allow_comments_default smallint, + blog_allow_pings_default smallint, + blog_server_offset float, + blog_convert_paras varchar(30), + blog_convert_paras_comments varchar(30), + blog_status_default smallint, + blog_allow_anon_comments smallint, + blog_allow_reg_comments smallint, + blog_allow_unreg_comments smallint, + blog_allow_pings smallint, + blog_moderate_unreg_comments smallint, + blog_require_comment_emails smallint, + blog_manual_approve_commenters smallint, + blog_moderate_pings smallint, + blog_words_in_excerpt smallint, + blog_ping_technorati smallint, + blog_ping_weblogs smallint, + blog_ping_blogs smallint, + blog_ping_others text, + blog_junk_score_threshold float, + blog_junk_folder_expiry integer, + blog_mt_update_key varchar(30), + blog_autodiscover_links smallint, + blog_welcome_msg text, + blog_old_style_archive_links smallint, + blog_archive_tmpl_monthly varchar(255), + blog_archive_tmpl_weekly varchar(255), + blog_archive_tmpl_daily varchar(255), + blog_archive_tmpl_individual varchar(255), + blog_archive_tmpl_category varchar(255), + blog_google_api_key varchar(32), + blog_sanitize_spec varchar(255), + blog_cc_license varchar(255), + blog_is_dynamic smallint, + blog_remote_auth_token varchar(50), + blog_children_modified_on timestamp, + blog_custom_dynamic_templates varchar(25) +); +create sequence mt_blog_id; +create index mt_blog_name on mt_blog (blog_name); + +create table mt_category ( + category_id integer primary key not null, + category_blog_id integer not null, + category_allow_pings smallint, + category_label varchar(100) not null, + category_description text, + category_author_id integer, + category_ping_urls text, + category_parent integer, + unique (category_blog_id, category_label) +); +create sequence mt_category_id; + +create table mt_comment ( + comment_id integer primary key not null, + comment_blog_id integer not null, + comment_entry_id integer not null, + comment_ip varchar(16), + comment_author varchar(100), + comment_email varchar(75), + comment_url varchar(255), + comment_commenter_id integer, + comment_visible smallint, + comment_text text, + comment_junk_status smallint not null default 0, + comment_junk_log text, + comment_junk_score float, + comment_created_on timestamp not null, + comment_modified_on timestamp not null, + comment_last_moved_on timestamp not null, + comment_created_by integer, + comment_modified_by integer +); +create sequence mt_comment_id; +create index mt_comment_created_on on mt_comment (comment_created_on); +create index mt_comment_entry_id on mt_comment (comment_entry_id); +create index mt_comment_blog_id on mt_comment (comment_blog_id); + +create table mt_entry ( + entry_id integer primary key not null, + entry_blog_id integer not null, + entry_status smallint not null, + entry_author_id integer not null, + entry_allow_comments smallint, + entry_allow_pings smallint, + entry_convert_breaks varchar(30), + entry_category_id integer, + entry_title varchar(255), + entry_excerpt text, + entry_text text, + entry_text_more text, + entry_to_ping_urls text, + entry_pinged_urls text, + entry_keywords text, + entry_tangent_cache text, + entry_created_on timestamp not null, + entry_modified_on timestamp not null, + entry_created_by integer, + entry_modified_by integer, + entry_week_number integer, + entry_basename varchar(50) not null +); +create sequence mt_entry_id; +create index mt_entry_blog_id on mt_entry (entry_blog_id); +create index mt_entry_status on mt_entry (entry_status); +create index mt_entry_author_id on mt_entry (entry_author_id); +create index mt_entry_created_on on mt_entry (entry_created_on); +create index mt_entry_basename on mt_entry (entry_basename); + +create table mt_ipbanlist ( + ipbanlist_id integer primary key not null, + ipbanlist_blog_id integer not null, + ipbanlist_ip varchar(15) not null, + ipbanlist_created_on timestamp not null, + ipbanlist_modified_on timestamp not null, + ipbanlist_created_by integer, + ipbanlist_modified_by integer +); +create sequence mt_ipbanlist_id; +create index mt_ipbanlist_blog_id on mt_ipbanlist (ipbanlist_blog_id); +create index mt_ipbanlist_ip on mt_ipbanlist (ipbanlist_ip); + +create table mt_log ( + log_id integer primary key not null, + log_message varchar(255), + log_ip varchar(16), + log_blog_id integer default 0, + log_created_on timestamp not null, + log_modified_on timestamp not null, + log_created_by integer, + log_modified_by integer +); +create sequence mt_log_id; +create index mt_log_created_on on mt_log (log_created_on); + +create table mt_notification ( + notification_id integer primary key not null, + notification_blog_id integer not null, + notification_name varchar(50), + notification_email varchar(75), + notification_url varchar(255), + notification_created_on timestamp not null, + notification_modified_on timestamp not null, + notification_created_by integer, + notification_modified_by integer +); +create sequence mt_notification_id; +create index mt_notification_blog_id on mt_notification (notification_blog_id); + +create table mt_permission ( + permission_id integer primary key not null, + permission_author_id integer not null, + permission_blog_id integer not null, + permission_role_mask integer, + permission_entry_prefs varchar(255), + unique (permission_blog_id, permission_author_id) +); +create sequence mt_permission_id; + +create table mt_placement ( + placement_id integer primary key not null, + placement_entry_id integer not null, + placement_blog_id integer not null, + placement_category_id integer not null, + placement_is_primary smallint not null +); +create sequence mt_placement_id; +create index mt_placement_entry_id on mt_placement (placement_entry_id); +create index mt_placement_category_id on mt_placement (placement_category_id); +create index mt_placement_is_primary on mt_placement (placement_is_primary); + +create table mt_plugindata ( + plugindata_id integer primary key not null, + plugindata_plugin varchar(50) not null, + plugindata_key varchar(255) not null, + plugindata_data bytea +); +create sequence mt_plugindata_id; +create index mt_plugindata_plugin on mt_plugindata (plugindata_plugin); +create index mt_plugindata_key on mt_plugindata (plugindata_key); + +create table mt_template ( + template_id integer primary key not null, + template_blog_id integer not null, + template_name varchar(50) not null, + template_type varchar(25) not null, + template_outfile varchar(255), + template_rebuild_me smallint, + template_text text, + template_linked_file varchar(255), + template_linked_file_mtime varchar(10), + template_linked_file_size integer, + template_created_on timestamp not null, + template_modified_on timestamp not null, + template_created_by integer, + template_modified_by integer, + template_build_dynamic smallint, + unique (template_blog_id, template_name) +); +create sequence mt_template_id; +create index mt_template_type on mt_template (template_type); + +create table mt_templatemap ( + templatemap_id integer primary key not null, + templatemap_blog_id integer not null, + templatemap_template_id integer not null, + templatemap_archive_type varchar(25) not null, + templatemap_file_template varchar(255), + templatemap_is_preferred smallint not null +); +create sequence mt_templatemap_id; +create index mt_templatemap_blog_id on mt_templatemap (templatemap_blog_id); +create index mt_templatemap_template_id on mt_templatemap (templatemap_template_id); +create index mt_templatemap_archive_type on mt_templatemap (templatemap_archive_type); +create index mt_templatemap_is_preferred on mt_templatemap (templatemap_is_preferred); + +create table mt_trackback ( + trackback_id integer primary key not null, + trackback_blog_id integer not null, + trackback_title varchar(255), + trackback_description text, + trackback_rss_file varchar(255), + trackback_url varchar(255), + trackback_entry_id integer not null, + trackback_category_id integer not null, + trackback_passphrase varchar(30), + trackback_is_disabled smallint, + trackback_created_on timestamp not null, + trackback_modified_on timestamp not null, + trackback_created_by integer, + trackback_modified_by integer +); +create sequence mt_trackback_id; +create index mt_trackback_blog_id on mt_trackback (trackback_blog_id); +create index mt_trackback_entry_id on mt_trackback (trackback_entry_id); +create index mt_trackback_category_id on mt_trackback (trackback_category_id); +create index mt_trackback_created_on on mt_trackback (trackback_created_on); + +create table mt_tbping ( + tbping_id integer primary key not null, + tbping_blog_id integer not null, + tbping_tb_id integer not null, + tbping_title varchar(255), + tbping_excerpt text, + tbping_source_url varchar(255), + tbping_ip varchar(15) not null, + tbping_blog_name varchar(255), + tbping_visible smallint, + tbping_junk_status smallint not null default 0, + tbping_junk_log text, + tbping_junk_score float, + tbping_created_on timestamp not null, + tbping_modified_on timestamp not null, + tbping_last_moved_on timestamp not null, + tbping_created_by integer, + tbping_modified_by integer +); +create sequence mt_tbping_id; +create index mt_tbping_blog_id on mt_tbping (tbping_blog_id); +create index mt_tbping_tb_id on mt_tbping (tbping_tb_id); +create index mt_tbping_ip on mt_tbping (tbping_ip); +create index mt_tbping_created_on on mt_tbping (tbping_created_on); + +create table mt_session ( + session_id varchar(80) primary key not null, + session_data bytea, + session_email varchar(255), + session_name varchar(255), + session_start integer not null, + session_kind varchar(2) +); + +create index mt_session_start on mt_session (session_start); + +create table mt_fileinfo ( + fileinfo_id integer primary key not null, + fileinfo_blog_id integer not null, + fileinfo_entry_id integer, + fileinfo_url varchar(255), + fileinfo_file_path varchar(255), + fileinfo_template_id integer, + fileinfo_templatemap_id integer, + fileinfo_archive_type varchar(255), + fileinfo_category_id integer, + fileinfo_startdate varchar(80), + fileinfo_virtual smallint +); +create sequence mt_fileinfo_id; +create index mt_fileinfo_blog_id on mt_fileinfo (fileinfo_blog_id); +create index mt_fileinfo_entry_id on mt_fileinfo (fileinfo_entry_id); +create index mt_fileinfo_url on mt_fileinfo (fileinfo_url); Index: /branches/mt4.11/schemas/Makefile =================================================================== --- /branches/mt4.11/schemas/Makefile (revision 1098) +++ /branches/mt4.11/schemas/Makefile (revision 1098) @@ -0,0 +1,36 @@ +all: postgres sqlite mysql oracle + +SQL = mt.sql + +mysql: $(SQL) + rm -f mysql.schema + touch mysql.schema + for i in $(SQL); do\ + ./sqlmangle mysql $$i >> mysql.schema\ + ; done + chmod -w mysql.schema + + +postgres: $(SQL) + rm -f postgres.schema + touch postgres.schema + for i in $(SQL); do\ + ./sqlmangle postgres $$i >> postgres.schema\ + ; done + chmod -w postgres.schema + +sqlite: $(SQL) + rm -f sqlite.schema + touch sqlite.schema + for i in $(SQL); do\ + ./sqlmangle sqlite $$i >> sqlite.schema\ + ; done + chmod -w sqlite.schema + +oracle: $(SQL) + rm -f oracle.schema + touch oracle.schema + for i in $(SQL); do\ + ./sqlmangle oracle $$i >> oracle.schema\ + ; done + chmod -w oracle.schema Index: /branches/mt4.11/schemas/mt.sql =================================================================== --- /branches/mt4.11/schemas/mt.sql (revision 1098) +++ /branches/mt4.11/schemas/mt.sql (revision 1098) @@ -0,0 +1,320 @@ +CREATE TABLE mt_author ( + author_id INTEGER SERIAL PRIMARY KEY, + author_name VARCHAR(50) NOT NULL, + author_type TINYINT NOT NULL, + author_nickname VARCHAR(50), + author_password VARCHAR(60) NOT NULL, + author_email VARCHAR(75) NOT NULL, + author_url VARCHAR(255), + author_can_create_blog TINYINT, + author_can_view_log TINYINT, + author_hint VARCHAR(75), + author_created_by INTEGER, + author_public_key TEXT, + author_preferred_language VARCHAR(50), + author_remote_auth_username VARCHAR(50), + author_remote_auth_token VARCHAR(50) +); +CREATE UNIQUE INDEX mt_author_name_type ON mt_author (author_name, author_type); +CREATE INDEX mt_author_email ON mt_author (author_email); + +CREATE TABLE mt_blog ( + blog_id INTEGER SERIAL PRIMARY KEY, + blog_name VARCHAR(255) NOT NULL, + blog_description TEXT, + blog_site_path VARCHAR(255), + blog_site_url VARCHAR(255), + blog_archive_path VARCHAR(255), + blog_archive_url VARCHAR(255), + blog_archive_type VARCHAR(255), + blog_archive_type_preferred VARCHAR(25), + blog_days_on_index SMALLINT, + blog_language VARCHAR(5), + blog_file_extension VARCHAR(10), + blog_email_new_comments TINYINT, + blog_email_new_pings TINYINT, + blog_allow_comment_html TINYINT, + blog_autolink_urls TINYINT, + blog_sort_order_posts VARCHAR(8), + blog_sort_order_comments VARCHAR(8), + blog_allow_comments_default TINYINT, + blog_allow_pings_default TINYINT, + blog_server_offset FLOAT, + blog_convert_paras VARCHAR(30), + blog_convert_paras_comments VARCHAR(30), + blog_status_default TINYINT, + blog_allow_anon_comments TINYINT, + blog_allow_reg_comments TINYINT, + blog_allow_unreg_comments TINYINT, + blog_moderate_unreg_comments TINYINT, + blog_require_comment_emails TINYINT, + blog_manual_approve_commenters TINYINT, + blog_words_in_excerpt SMALLINT, + blog_ping_technorati TINYINT, + blog_ping_weblogs TINYINT, + blog_ping_blogs TINYINT, + blog_ping_others TEXT, + blog_mt_update_key VARCHAR(30), + blog_autodiscover_links TINYINT, + blog_welcome_msg TEXT, + blog_old_style_archive_links TINYINT, + blog_archive_tmpl_monthly VARCHAR(255), + blog_archive_tmpl_weekly VARCHAR(255), + blog_archive_tmpl_daily VARCHAR(255), + blog_archive_tmpl_individual VARCHAR(255), + blog_archive_tmpl_category VARCHAR(255), + blog_google_api_key VARCHAR(32), + blog_sanitize_spec VARCHAR(255), + blog_cc_license VARCHAR(255), + blog_is_dynamic TINYINT, + blog_remote_auth_token VARCHAR(50), + blog_children_modified_on TIMESTAMP, + blog_custom_dynamic_templates VARCHAR(25) +); +CREATE INDEX mt_blog_name ON mt_blog (blog_name); + +CREATE TABLE mt_category ( + category_id INTEGER SERIAL PRIMARY KEY, + category_blog_id INTEGER NOT NULL, + category_allow_pings TINYINT, + category_label VARCHAR(100) NOT NULL, + category_description TEXT, + category_author_id INTEGER, + category_ping_urls TEXT, + category_parent INTEGER +); +--CREATE UNIQUE INDEX mt_category_blog_label ON mt_category (category_blog_id, category_label); + +CREATE TABLE mt_comment ( + comment_id INTEGER SERIAL PRIMARY KEY, + comment_blog_id INTEGER NOT NULL, + comment_entry_id INTEGER NOT NULL, + comment_ip VARCHAR(16), + comment_author VARCHAR(100), + comment_email VARCHAR(75), + comment_url VARCHAR(255), + comment_commenter_id INTEGER, + comment_visible TINYINT, + commenter_is_junk TINYINT NOT NULL, + comment_last_moved_on TIMESTAMP NOT NULL, + comment_junk_score FLOAT, + comment_junk_log TEXT, + comment_text TEXT, + comment_created_on TIMESTAMP NOT NULL, + comment_modified_on TIMESTAMP NOT NULL, + comment_created_by INTEGER, + comment_modified_by INTEGER +); +CREATE INDEX mt_comment_ip ON mt_comment (comment_ip); +CREATE INDEX mt_comment_created_on ON mt_comment (comment_created_on); +CREATE INDEX mt_comment_entry_id ON mt_comment (comment_entry_id); +CREATE INDEX mt_comment_blog_id ON mt_comment (comment_blog_id); +CREATE INDEX mt_comment_commenter_id ON mt_comment (comment_commenter_id); +CREATE INDEX mt_comment_visible ON mt_comment (comment_visible); +CREATE INDEX mt_comment_is_junk ON mt_comment (comment_is_junk); +CREATE INDEX mt_comment_last_moved_on ON mt_comment (comment_last_moved_on); +CREATE INDEX mt_comment_junk_score ON mt_comment (comment_junk_score); + +CREATE TABLE mt_entry ( + entry_id INTEGER SERIAL PRIMARY KEY, + entry_blog_id INTEGER NOT NULL, + entry_status TINYINT NOT NULL, + entry_author_id INTEGER NOT NULL, + entry_allow_comments TINYINT, + entry_allow_pings TINYINT, + entry_convert_breaks VARCHAR(30), + entry_category_id INTEGER, + entry_title VARCHAR(255), + entry_excerpt TEXT, + entry_text TEXT, + entry_text_more TEXT, + entry_to_ping_urls TEXT, + entry_pinged_urls TEXT, + entry_keywords TEXT, + entry_tangent_cache TEXT, + entry_created_on TIMESTAMP NOT NULL, + entry_modified_on TIMESTAMP NOT NULL, + entry_created_by INTEGER, + entry_modified_by INTEGER, + entry_basename VARCHAR(50) NOT NULL +); +CREATE INDEX mt_entry_blog_id ON mt_entry (entry_blog_id); +CREATE INDEX mt_entry_status ON mt_entry (entry_status); +CREATE INDEX mt_entry_author_id ON mt_entry (entry_author_id); +CREATE INDEX mt_entry_created_on ON mt_entry (entry_created_on); +CREATE INDEX mt_entry_basename ON mt_entry (entry_basename); + +CREATE TABLE mt_ipbanlist ( + ipbanlist_id INTEGER SERIAL PRIMARY KEY, + ipbanlist_blog_id INTEGER NOT NULL, + ipbanlist_ip VARCHAR(15) NOT NULL, + ipbanlist_created_on TIMESTAMP NOT NULL, + ipbanlist_modified_on TIMESTAMP NOT NULL, + ipbanlist_created_by INTEGER, + ipbanlist_modified_by INTEGER +); +CREATE INDEX mt_ipbanlist_blog_id ON mt_ipbanlist (ipbanlist_blog_id); +CREATE INDEX mt_ipbanlist_ip ON mt_ipbanlist (ipbanlist_ip); + +CREATE TABLE mt_log ( + log_id INTEGER SERIAL PRIMARY KEY, + log_message VARCHAR(255), + log_ip VARCHAR(16), + log_created_on TIMESTAMP NOT NULL, + log_modified_on TIMESTAMP NOT NULL, + log_created_by INTEGER, + log_modified_by INTEGER, +); +CREATE INDEX mt_log_created_on ON mt_log (log_created_on); + +CREATE TABLE mt_notification ( + notification_id INTEGER SERIAL PRIMARY KEY, + notification_blog_id INTEGER NOT NULL, + notification_name VARCHAR(50), + notification_email VARCHAR(75), + notification_url VARCHAR(255), + notification_created_on TIMESTAMP NOT NULL, + notification_modified_on TIMESTAMP NOT NULL, + notification_created_by INTEGER, + notification_modified_by INTEGER, +); +CREATE INDEX mt_notification_blog_id ON mt_notification (notification_blog_id); + +CREATE TABLE mt_permission ( + permission_id INTEGER SERIAL PRIMARY KEY, + permission_author_id INTEGER NOT NULL, + permission_blog_id INTEGER NOT NULL, + permission_role_mask SMALLINT, + permission_entry_prefs VARCHAR(255) +); +CREATE UNIQUE INDEX mt_permission_blog_author ON mt_permission (permission_blog_id, permission_author_id); + +CREATE TABLE mt_placement ( + placement_id INTEGER SERIAL PRIMARY KEY, + placement_entry_id INTEGER NOT NULL, + placement_blog_id INTEGER NOT NULL, + placement_category_id INTEGER NOT NULL, + placement_is_primary TINYINT NOT NULL +); +CREATE INDEX mt_placement_entry_id ON mt_placement (placement_entry_id); +CREATE INDEX mt_placement_category_id ON mt_placement (placement_category_id); +CREATE INDEX mt_placement_is_primary ON mt_placement (placement_is_primary); + +CREATE TABLE mt_plugindata ( + plugindata_id INTEGER SERIAL PRIMARY KEY, + plugindata_plugin VARCHAR(50) NOT NULL, + plugindata_key VARCHAR(255) NOT NULL, + plugindata_data BLOB +); +CREATE INDEX mt_plugindata_plugin ON mt_plugindata (plugindata_plugin); +CREATE INDEX mt_plugindata_key ON mt_plugindata (plugindata_key); + +CREATE TABLE mt_template ( + template_id INTEGER SERIAL PRIMARY KEY, + template_blog_id INTEGER NOT NULL, + template_name VARCHAR(50) NOT NULL, + template_type VARCHAR(25) NOT NULL, + template_outfile VARCHAR(255), + template_rebuild_me TINYINT default 1, + template_text TEXT, + template_linked_file VARCHAR(255), + template_linked_file_mtime VARCHAR(10), + template_linked_file_size MEDIUMINT, + template_created_on TIMESTAMP NOT NULL, + template_modified_on TIMESTAMP NOT NULL, + template_created_by INTEGER, + template_modified_by INTEGER, + template_build_dynamic TINYINT +); +CREATE UNIQUE INDEX mt_template_blog_name ON mt_template (template_blog_id, template_name); +CREATE INDEX mt_template_type ON mt_template (template_type); + +CREATE TABLE mt_templatemap ( + templatemap_id INTEGER SERIAL PRIMARY KEY, + templatemap_blog_id INTEGER NOT NULL, + templatemap_template_id INTEGER NOT NULL, + templatemap_archive_type VARCHAR(25) NOT NULL, + templatemap_file_template VARCHAR(255), + templatemap_is_preferred TINYINT NOT NULL +); +CREATE INDEX mt_templatemap_blog_id ON mt_templatemap (templatemap_blog_id); +CREATE INDEX mt_templatemap_template_id ON mt_templatemap (templatemap_template_id); +CREATE INDEX mt_templatemap_archive_type ON mt_templatemap (templatemap_archive_type); +CREATE INDEX mt_templatemap_is_preferred ON mt_templatemap (templatemap_is_preferred); + +CREATE TABLE mt_trackback ( + trackback_id INTEGER SERIAL PRIMARY KEY, + trackback_blog_id INTEGER NOT NULL, + trackback_title VARCHAR(255), + trackback_description TEXT, + trackback_rss_file VARCHAR(255), + trackback_url VARCHAR(255), + trackback_entry_id INTEGER NOT NULL, + trackback_category_id INTEGER NOT NULL, + trackback_passphrase VARCHAR(30), + trackback_is_disabled TINYINT default 0, + trackback_created_on TIMESTAMP NOT NULL, + trackback_modified_on TIMESTAMP NOT NULL, + trackback_created_by INTEGER, + trackback_modified_by INTEGER +); +CREATE INDEX mt_trackback_blog_id ON mt_trackback (trackback_blog_id); +CREATE INDEX mt_trackback_entry_id ON mt_trackback (trackback_entry_id); +CREATE INDEX mt_trackback_category_id ON mt_trackback (trackback_category_id); +CREATE INDEX mt_trackback_created_on ON mt_trackback (trackback_created_on); + +CREATE TABLE mt_tbping ( + tbping_id INTEGER SERIAL PRIMARY KEY, + tbping_blog_id INTEGER NOT NULL, + tbping_tb_id INTEGER NOT NULL, + tbping_title VARCHAR(255), + tbping_excerpt TEXT, + tbping_source_url VARCHAR(255), + tbping_ip VARCHAR(15) NOT NULL, + tbping_blog_name VARCHAR(255), + tbping_visible TINYINT, + tbping_is_junk TINYINT NOT NULL, + tbping_junk_score FLOAT, + tbping_junk_log TEXT, + tbping_last_moved_on TIMESTAMP NOT NULL, + tbping_created_on TIMESTAMP NOT NULL, + tbping_modified_on TIMESTAMP NOT NULL, + tbping_created_by INTEGER, + tbping_modified_by INTEGER +); +CREATE INDEX mt_tbping_blog_id ON mt_tbping (tbping_blog_id); +CREATE INDEX mt_tbping_tb_id ON mt_tbping (tbping_tb_id); +CREATE INDEX mt_tbping_ip ON mt_tbping (tbping_ip); +CREATE INDEX mt_tbping_created_on ON mt_tbping (tbping_created_on); +CREATE INDEX mt_tbping_last_moved_on ON mt_tbping (tbping_last_moved_on); +CREATE INDEX mt_tbping_is_junk ON mt_tbping (tbping_is_junk); +CREATE INDEX mt_tbping_visible ON mt_tbping (tbping_visible); +CREATE INDEX mt_tbping_junk_score ON mt_tbping (tbping_junk_score); + +CREATE TABLE mt_session ( + session_id VARCHAR(80) PRIMARY KEY, + session_data TEXT, + session_email VARCHAR(255), + session_name VARCHAR(255), + session_start int NOT NULL, + session_kind VARCHAR(2) +); +CREATE INDEX mt_session_start ON mt_session (session_start); + +CREATE TABLE mt_fileinfo ( + fileinfo_id INTEGER PRIMARY KEY SERIAL, + fileinfo_blog_id INTEGER NOT NULL, + fileinfo_entry_id INTEGER, + fileinfo_url VARCHAR(255), + fileinfo_file_path TEXT, + fileinfo_template_id INTEGER, + fileinfo_templatemap_id INTEGER, + fileinfo_archive_type VARCHAR(255), + fileinfo_category_id INTEGER, + fileinfo_startdate VARCHAR(80), + fileinfo_virtual TINYINT +); +CREATE INDEX mt_fileinfo_blog_id ON mt_fileinfo (fileinfo_blog_id); +CREATE INDEX mt_fileinfo_entry_id ON mt_fileinfo (fileinfo_entry_id); +CREATE INDEX mt_fileinfo_url ON mt_fileinfo (fileinfo_url); + Index: /branches/mt4.11/search_templates/default.tmpl =================================================================== --- /branches/mt4.11/search_templates/default.tmpl (revision 1098) +++ /branches/mt4.11/search_templates/default.tmpl (revision 1098) @@ -0,0 +1,177 @@ + + + + + " /> + + + + ########## + + + " href="<$MTCGIPath$><$MTSearchScript$>?searchtag=<$MTSearchString encode_url="1"$>&Template=feed&IncludeBlogs=<$MTSearchIncludeBlogs$>" /> + + <MT_TRANS phrase="Search Results"> + + +
+
+ + + +
+
+
+
+ + + ########## + + +

+
+ +

" />

+

+
+ + + + ########## + + + +

+ + + + + + +

+
+ + +

<$MTEntryTitle$>

+

<$MTEntryExcerpt$> <$MTEntryEditLink$>

+ +
+

:

+ +
+ + +

+ by [_1] on [_2]" params="<$MTEntryAuthorDisplayName$>%%<$MTEntryDate$>"> +

+ + +
+ + + + + + + + ########## + + +

+ + + + + + +

+

+ + + +

+

:

+
+

""

+
+

:

+
+

+

+
+ +
+
+ + ########## + ########## + + + + + ########## + + + "> + + + + + + + + + +
+
+ + + ########## + +
+

+
+

<$MTGetVar name="search_feed_description"> [">]

+

+ <$MTGetVar name=" width="9" height="9" /> =<$MTSearchString encode_url="1"$>&Template=feed&IncludeBlogs=<$MTSearchIncludeBlogs$>" title=""> +

+
+
+ + + ########## + + +
+

+
+

+ +
+
+ + +
+
+ + + +
+
#### #### +
+
#### #### + + Index: /branches/mt4.11/search_templates/results_feed.tmpl =================================================================== --- /branches/mt4.11/search_templates/results_feed.tmpl (revision 1098) +++ /branches/mt4.11/search_templates/results_feed.tmpl (revision 1098) @@ -0,0 +1,33 @@ +<$MTHTTPContentType type="application/atom+xml"$>"?> + + <MT_TRANS phrase="Search Results for [_1]" params="<$MTSearchString remove_html="1" encode_xml="1"$>"> + tag:<$MTCGIHost exclude_port="1" encode_xml="1"$>,<$MTDate format="%Y"$>:<$MTCGIRelativeURL encode_xml="1"$>/feed/<$MTSearchString remove_html="1" encode_xml="1"$> + + " /> + <$MTDate utc="1" format="%Y-%m-%dT%H:%M:%SZ"$> + Movable Type <$MTVersion$> + " /> + <$MTSearchResultCount$> + 1 + <$MTSearchResultCount$> + + + <$MTEntryTitle remove_html="1" encode_xml="1"$> + " /> + <$MTEntryAtomID$> + <$MTEntryDate utc="1" format="%Y-%m-%dT%H:%M:%SZ"$> + <$MTEntryModifiedDate utc="1" format="%Y-%m-%dT%H:%M:%SZ"$> + + <$MTEntryAuthorDisplayName encode_xml="1"$> + <$MTEntryAuthorURL encode_xml="1"$> + + " label="<$MTCategoryLabel encode_xml="1"$>" scheme="http://www.sixapart.com/ns/types#category" /> + " label="<$MTTagName encode_xml="1"$>" scheme="http://www.sixapart.com/ns/types#tag" /> + " xml:base="<$MTBlogURL encode_xml="1"$>"> + <$MTEntryExcerpt remove_html="1" encode_html="1"$> + + + + Index: /branches/mt4.11/search_templates/comments.tmpl =================================================================== --- /branches/mt4.11/search_templates/comments.tmpl (revision 1098) +++ /branches/mt4.11/search_templates/comments.tmpl (revision 1098) @@ -0,0 +1,69 @@ + + + + + + + +<MT_TRANS phrase="Search Results"> + + + + + +
+ + + +
+ +
+ + + +

+ +

+ +" /> +

+ +
+ + +

<$MTEntryTitle$>

+

<$MTEntryExcerpt$> <$MTEntryEditLink$>

+

+ + + +

+ +

+ + + +

+ +

+ + +
+
+ + + Index: /branches/mt4.11/search_templates/results_feed_rss2.tmpl =================================================================== --- /branches/mt4.11/search_templates/results_feed_rss2.tmpl (revision 1098) +++ /branches/mt4.11/search_templates/results_feed_rss2.tmpl (revision 1098) @@ -0,0 +1,26 @@ +<$MTHTTPContentType type="application/rss+xml"$>"?> + + +<MT_TRANS phrase="Search Results for [_1]" params="<$MTSearchString remove_html="1" encode_xml="1"$>"> +<$MTCGIPath$><$MTSearchScript$>?search=<$MTSearchString$>&Template=<$MTSearchTemplateID$>&IncludeBlogs=<$MTSearchIncludeBlogs$> +en-us +<$MTDate format="%a, %d %b %Y %H:%M:%S "$><$MTBlogTimezone no_colon="1"$> +http://blogs.law.harvard.edu/tech/rss +Movable Type <$MTVersion$> +1440 +<$MTSearchResultCount$> +1 +<$MTSearchResultCount$> + + +<$MTEntryTitle remove_html="1" encode_xml="1"$> +<$MTEntryLink encode_xml="1"$> +<$MTEntryExcerpt encode_xml="1"$> +<$MTEntryDate format="%a, %d %b %Y %H:%M:%S "$><$MTBlogTimezone no_colon="1"$> +<$MTEntryLink encode_xml="1"$> +<$MTEntryAuthorDisplayName encode_xml="1"$> +<$MTCGIPath$><$MTCommentScript$>?entry_id=<$MTEntryID$> +<$MTCategoryLabel dirify="1" encode_xml="1"$> + + + Index: /branches/mt4.11/extlib/File/Temp.pm =================================================================== --- /branches/mt4.11/extlib/File/Temp.pm (revision 1098) +++ /branches/mt4.11/extlib/File/Temp.pm (revision 1098) @@ -0,0 +1,1863 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=begin __INTERNALS + +=head1 PORTABILITY + +This module is designed to be portable across operating systems +and it currently supports Unix, VMS, DOS, OS/2 and Windows. When +porting to a new OS there are generally three main issues +that have to be solved: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C reliable? By default all the +return values from C are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C fails +then the C comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + + $fh = tempfile(); + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + ($fh, $file) = tmpfile(); + + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=begin later + +Objects (NOT YET IMPLEMENTED): + + require File::Temp; + + $fh = new File::Temp($template); + $fname = $fh->filename; + +=end later + +=head1 DESCRIPTION + +C can be used to create and open temporary files in a safe way. +The tempfile() function can be used to return the name and the open +filehandle of a temporary file. The tempdir() function can +be used to create a temporary directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.005 so give them what they want :-) +use 5.005; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); + +$DEBUG = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp'); + +# Version number + +$VERSION = '0.12'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 10; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; + +for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; +} + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (eg 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must contain at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry that means we are in the current + # directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + unless (-w _) { + ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n"; + return (); + } + + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + my $safeerr; + unless (_is_safe($parent,\$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + my $safeerr; + unless (_is_verysafe($parent, \$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( $options{"unlink_on_close"} ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # Reset umask + umask($umask); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + # Reset umask + umask($umask); + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Open the temp directory + if (mkdir( $path, 0700)) { + # created okay + # Reset umask + umask($umask); + + return undef, $path; + } else { + + # Reset umask + umask($umask); + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to return a random character from the +# character list. Does not do an srand() since rand() +# will do one automatically + +# No arguments. Return value is the random character + +# No longer called since _replace_XX runs a few percent faster if +# I inline the code. This is important if we are creating thousands of +# temporary files. + +sub _randchar { + + $CHARS[ int( rand( $#CHARS ) ) ]; + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } + + return $path; +} + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + }; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the real uid from the $< variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d _) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k _) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories + # They will only exist in this block + # This means we only have to set up a single END block to remove all files + # @files_to_unlink contains an array ref with the filehandle and filename + my (@files_to_unlink, @dirs_to_unlink); + + # Set up an end block to use these arrays + END { + # Files + foreach my $file (@files_to_unlink) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + foreach my $dir (@dirs_to_unlink) { + if (-d $dir) { + rmtree($dir, $DEBUG, 1); + } + } + + } + + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; + push (@dirs_to_unlink, $fname); + + } else { + carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; + } + + } else { + + if (-f $fname) { + + # file exists so store handle and name for later removal + push(@files_to_unlink, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; + } + + } + + } + + +} + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +in the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits. Default is for the file +to be removed if a file handle is requested and to be kept if the +filename is requested. In a scalar context (where no filename is +returned) the file is always deleted either on exit or when it is closed. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( $template, DIR => $dir ); + +If called in scalar context, only the filehandle is returned +and the file will automatically be deleted when closed (see +the description of tmpfile() elsewhere in this document). +This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition +by fumbling with the filename. On systems that can not unlink +an open file or can not mark a file as temporary when it is opened +(for example, Windows NT uses the C flag)) +the file is marked for deletion when the program ends (equivalent +to setting UNLINK to 1). The C flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +Options can be combined as required. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it. + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B + +This is the recommended interface for creation of temporary directories. +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, creat the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C option is ignored if C is set +explicitly. Additionally, C is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F. The trailing X's are replaced +with unique alphanumeric combinations. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C and suffix of C<.dat> +would generate a file similar to F. + +Returns just the filehandle alone when called in scalar context. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. +Returns undef on failure. + +Directory must be removed by the caller. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L +using the mkstemp() from this module. + +Unlike the L implementations, the directory used +for the temporary file is not specified in a system include +file (C) but simply depends on the choice of tmpdir() +returned by L. On some implementations this +location can be set using the C environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L for information on the choice of temporary +directory for a particular operating system. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B + +In scalar context, returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C +with C if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) or die "Error unlinking file $path safely"; + +Returns false on error. The filehandle is not closed since on some +occasions this is not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C and C fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C being more accurate than +C, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Unlinking $path using unlink0\n" + if $DEBUG; + + # Stat the filehandle + my @fh = stat $fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f _) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and +is writable, that the umask() is fixed before opening of the file, +that temporary files are opened only if they do not already exist, and +that possible race conditions are avoided. Finally the L +function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C, C, C etc) rather than +simply by root. + +This is required since on many unix systems C is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C is set to MEDIUM or higher. + +=back + +=cut + +{ + my $TopSystemUID = 10; + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. + +=head1 SEE ALSO + +L, L, L, L + +See L and L for different implementations of +temporary file handling. + +=head1 AUTHOR + +Tim Jenness Et.jenness@jach.hawaii.eduE + +Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + + +1; Index: /branches/mt4.11/extlib/File/Listing.pm =================================================================== --- /branches/mt4.11/extlib/File/Listing.pm (revision 1098) +++ /branches/mt4.11/extlib/File/Listing.pm (revision 1098) @@ -0,0 +1,313 @@ +# +# $Id: Listing.pm,v 1.11 1999/03/20 07:37:35 gisle Exp $ + +package File::Listing; + +sub Version { $VERSION; } +$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/); + +=head1 NAME + +parse_dir - parse directory listing + +=head1 SYNOPSIS + + use File::Listing; + for (parse_dir(`ls -l`)) { + ($name, $type, $size, $mtime, $mode) = @$_; + next if $type ne 'f'; # plain file + #... + } + + # directory listing can also be read from a file + open(LISTING, "zcat ls-lR.gz|"); + $dir = parse_dir(\*LISTING, '+0000'); + +=head1 DESCRIPTION + +The parse_dir() routine can be used to parse directory +listings. Currently it only understand Unix C<'ls -l'> and C<'ls -lR'> +format. It should eventually be able to most things you might get +back from a ftp server file listing (LIST command), i.e. VMS listings, +NT listings, DOS listings,... + +The first parameter to parse_dir() is the directory listing to parse. +It can be a scalar, a reference to an array of directory lines or a +glob representing a filehandle to read the directory listing from. + +The second parameter is the time zone to use when parsing time stamps +in the listing. If this value is undefined, then the local time zone is +assumed. + +The third parameter is the type of listing to assume. The values will +be strings like 'unix', 'vms', 'dos'. Currently only 'unix' is +implemented and this is also the default value. Ideally, the listing +type should be determined automatically. + +The fourth parameter specifies how unparseable lines should be treated. +Values can be 'ignore', 'warn' or a code reference. Warn means that +the perl warn() function will be called. If a code reference is +passed, then this routine will be called and the return value from it +will be incorporated in the listing. The default is 'ignore'. + +Only the first parameter is mandatory. + +The return value from parse_dir() is a list of directory entries. In +a scalar context the return value is a reference to the list. The +directory entries are represented by an array consisting of [ +$filename, $filetype, $filesize, $filetime, $filemode ]. The +$filetype value is one of the letters 'f', 'd', 'l' or '?'. The +$filetime value is the seconds since Jan 1, 1970. The +$filemode is a bitmask like the mode returned by stat(). + +=head1 CREDITS + +Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and +Net::FTP's parse_dir (Graham Barr). + +=cut + +require Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw(parse_dir); + +use strict; + +use Carp (); +use HTTP::Date qw(str2time); + +sub parse_dir ($;$$$) +{ + my($dir, $tz, $fstype, $error) = @_; + + $fstype ||= 'unix'; + $fstype = "File::Listing::" . lc $fstype; + + my @args = $_[0]; + push(@args, $tz) if(@_ >= 2); + push(@args, $error) if(@_ >= 4); + + $fstype->parse(@args); +} + +sub line { Carp::croak("Not implemented yet"); } +sub init { } # Dummy sub + +sub file_mode ($) +{ + # This routine was originally borrowed from Graham Barr's + # Net::FTP package. + + local $_ = shift; + my $mode = 0; + my($type,$ch); + + s/^(.)// and $type = $1; + + while (/(.)/g) { + $mode <<= 1; + $mode |= 1 if $1 ne "-" && + $1 ne 'S' && + $1 ne 't' && + $1 ne 'T'; + } + + $type eq "d" and $mode |= 0040000 or # Directory + $type eq "l" and $mode |= 0120000 or # Symbolic Link + $mode |= 0100000; # Regular File + + $mode |= 0004000 if /^...s....../i; + $mode |= 0002000 if /^......s.../i; + $mode |= 0001000 if /^.........t/i; + + $mode; +} + +sub parse +{ + my($pkg, $dir, $tz, $error) = @_; + + # First let's try to determine what kind of dir parameter we have + # received. We allow both listings, reference to arrays and + # file handles to read from. + + if (ref($dir) eq 'ARRAY') { + # Already splitted up + } elsif (ref($dir) eq 'GLOB') { + # A file handle + } elsif (ref($dir)) { + Carp::croak("Illegal argument to parse_dir()"); + } elsif ($dir =~ /^\*\w+(::\w+)+$/) { + # This scalar looks like a file handle, so we assume it is + } else { + # A normal scalar listing + $dir = [ split(/\n/, $dir) ]; + } + + $pkg->init(); + + my @files = (); + if (ref($dir) eq 'ARRAY') { + for (@$dir) { + push(@files, $pkg->line($_, $tz, $error)); + } + } else { + local($_); + while (<$dir>) { + chomp; + push(@files, $pkg->line($_, $tz, $error)); + } + } + wantarray ? @files : \@files; +} + + +package File::Listing::unix; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir); +no strict qw(vars); + +@ISA = qw(File::Listing); + + +sub init +{ + $curdir = ''; +} + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + #study; + + my ($kind, $size, $date, $name); + if (($kind, $size, $date, $name) = + /^([\-FlrwxsStTdD]{10}) # Type and permission bits + .* # Graps + \D(\d+) # File size + \s+ # Some space + (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})) # Date + \s+ # Some more space + (.*)$ # File name + /x ) + + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) { + $name = $1; + $type = "l $2"; + } elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file + $type = 'f'; + } elsif ($kind =~ /^[dD]/) { + $type = 'd'; + $size = undef; # Don't believe the reported size + } + return [$name, $type, $size, str2time($date, $tz), + File::Listing::file_mode($kind)]; + + } elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) { + my $dir = $1; + return () if $dir eq '.'; + $curdir = $dir; + return (); + } elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) { + return (); + } elsif (/not found/ || # OSF1, HPUX, and SunOS return + # "$file not found" + /No such file/ || # IRIX returns + # "UX:ls: ERROR: Cannot access $file: No such file or directory" + # Solaris returns + # "$file: No such file or directory" + /cannot find/ # Windows NT returns + # "The system cannot find the path specified." + ) { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Error: $_\n" if $error eq 'warn'; + return (); + } elsif ($_ eq '') { # AIX, and Linux return nothing + return () unless defined $error; + &$error("No such file or directory") if ref($error) eq 'CODE'; + warn "Warning: No such file or directory\n" if $error eq 'warn'; + return (); + } else { + # parse failed, check if the dosftp parse understands it + return(File::Listing::dosftp->line($_,$tz,$error)); + } + +} + +package File::Listing::dosftp; + +use HTTP::Date qw(str2time); + +# A place to remember current directory from last line parsed. +use vars qw($curdir); +no strict qw(vars); + +@ISA = qw(File::Listing); + +sub init +{ + $curdir = ''; +} + +sub line +{ + shift; # package name + local($_) = shift; + my($tz, $error) = @_; + + s/\015//g; + + my ($kind, $size, $date, $name); + + # 02-05-96 10:48AM 1415 src.slf + # 09-10-96 09:18AM sl_util + if (($date,$size_or_dir,$name) = + /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info + \s+ # Some space + (<\w{3}>|\d+) # Dir or Size + \s+ # Some more space + (.+)$ # File name + /x ) + { + return if $name eq '.' || $name eq '..'; + $name = "$curdir/$name" if length $curdir; + my $type = '?'; + if ($size_or_dir eq '') { + $type = "d"; + $size = ""; # directories have no size in the pc listing + } else { + $type = 'f'; + $size = $size_or_dir; + } + return [$name, $type, $size, str2time($date, $tz), + File::Listing::file_mode($kind)]; + + } else { + return () unless defined $error; + &$error($_) if ref($error) eq 'CODE'; + warn "Can't parse: $_\n" if $error eq 'warn'; + return (); + } + +} + +package File::Listing::vms; +@File::Listing::unix::ISA = qw(File::Listing); + +package File::Listing::netware; +@File::Listing::unix::ISA = qw(File::Listing); + +1; Index: /branches/mt4.11/extlib/File/Copy/Recursive.pm =================================================================== --- /branches/mt4.11/extlib/File/Copy/Recursive.pm (revision 1098) +++ /branches/mt4.11/extlib/File/Copy/Recursive.pm (revision 1098) @@ -0,0 +1,546 @@ +package File::Copy::Recursive; + +use strict; +use warnings; + +use Carp; +use File::Copy; +use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir); +our $VERSION = '0.23'; + +our $MaxDepth = 0; +our $KeepMode = 1; +our $CPRFComp = 0; +our $CopyLink = eval { symlink '',''; 1 } || 0; +our $PFSCheck = 1; +our $RemvBase = 0; +our $NoFtlPth = 0; +our $ForcePth = 0; +our $CopyLoop = 0; +our $RMTrgFil = 0; +our $RMTrgDir = 0; +our $CondCopy = {}; + +my $samecheck = sub { + my $one = ''; + if($PFSCheck) { + $one = join( '-', ( stat $_[0] )[0,1] ) || ''; + my $two = join( '-', ( stat $_[1] )[0,1] ) || ''; + croak "$_[0] and $_[1] are identical" if $one eq $two && $one; + } + if(-d $_[0] && !$CopyLoop) { + $one = join( '-', ( stat $_[0] )[0,1] ) if !$one; + my $abs = File::Spec->rel2abs($_[1]); + my @pth = File::Spec->splitdir( $abs ); + while(@pth) { + my $cur = File::Spec->catdir(@pth); + last if !$cur; # probably not necessary, but nice to have just in case :) + my $two = join( '-', ( stat $cur )[0,1] ) || ''; + croak "Caught Deep Recursion Condition: $_[0] contains $_[1]" if $one eq $two && $one; + pop @pth; + } + } +}; + +my $move = sub { + my $fl = shift; + my @x; + if($fl) { + @x = fcopy(@_) or return; + } else { + @x = dircopy(@_) or return; + } + if(@x) { + if($fl) { + unlink $_[0] or return; + } else { + pathrmdir($_[0]) or return; + } + if($RemvBase) { + my ($volm, $path) = File::Spec->splitpath($_[0]); + pathrm(File::Spec->catpath($volm,$path), $ForcePth, $NoFtlPth) or return; + } + } + return wantarray ? @x : $x[0]; +}; + +my $ok_todo_asper_condcopy = sub { + my $org = shift; + my $copy = 1; + if(exists $CondCopy->{$org}) { + if($CondCopy->{$org}{'md5'}) { + + } + if($copy) { + + } + } + return $copy; +}; + +sub fcopy { + $samecheck->(@_); + if($RMTrgFil && (-d $_[1] || -e $_[1]) ) { + my $trg = $_[1]; + if( -d $trg ) { + my @trgx = File::Spec->splitpath( $_[0] ); + $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] ); + } + if(-e $trg) { + if($RMTrgFil == 1) { + unlink $trg or carp "\$RMTrgFil failed: $!"; + } else { + unlink $trg or return; + } + } + } + my ($volm, $path) = File::Spec->splitpath($_[1]); + if($path && !-d $path) { + pathmk(File::Spec->catpath($volm,$path), $NoFtlPth); + } + if(-l $_[0] && $CopyLink) { + symlink readlink(shift()), shift() or return; + } else { + copy(@_) or return; + + my @base_file = File::Spec->splitpath($_[0]); + my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1]; + + chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode; + } + return wantarray ? (1,0,0) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings +} + +sub rcopy { + -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*' ? dircopy(@_) + : fcopy(@_); +} + +sub dircopy { + if($RMTrgDir && -d $_[1]) { + if($RMTrgDir == 1) { + pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!"; + } else { + pathrmdir($_[1]) or return; + } + } + my $globstar = 0; + my $_zero = $_[0]; + my $_one = $_[1]; + if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') { + $globstar = 1; + $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ); + } + croak "$_zero and $_[1] are the same" if $_zero eq $_[1]; + $samecheck->(@_); + croak "$_zero is not a directory" if !-d $_zero; + croak "$_[1] is not a directory" if -e $_[1] && !-d $_[1]; + + if(!-d $_[1]) { + pathmk($_[1], $NoFtlPth) or return; + } else { + if($CPRFComp && !$globstar) { + my @parts = File::Spec->splitdir($_zero); + while($parts[ $#parts ] eq '') { pop @parts; } + $_one = File::Spec->catdir($_[1], $parts[$#parts]); + } + } + my $baseend = $_one; + my $level = 0; + my $filen = 0; + my $dirn = 0; + + my $recurs; #must be my()ed before sub {} since it calls itself + $recurs = sub { + my ($str,$end,$buf) = @_; + $filen++ if $end eq $baseend; + $dirn++ if $end eq $baseend; + mkdir $end or return if !-d $end; + chmod scalar((stat($str))[2]), $end if $KeepMode; + if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) { + return ($filen,$dirn,$level) if wantarray; + return $filen; + } + $level++; + + opendir(my $pth_dh, $str) or return; + my @files = grep( $_ ne '.' && $_ ne '..', readdir($pth_dh)); + closedir $pth_dh; + + for my $file (@files) { + my ($file_ut) = $file =~ m{ (.*) }xms; + my $org = File::Spec->catfile($str, $file_ut); + my $new = File::Spec->catfile($end, $file_ut); + if(-l $org && $CopyLink) { + symlink readlink($org), $new or return; + } + elsif(-d $org) { + $recurs->($org,$new,$buf) if defined $buf; + $recurs->($org,$new) if !defined $buf; + $filen++; + $dirn++; + } + else { + if($ok_todo_asper_condcopy->($org)) { + fcopy($org,$new,$buf) or return if defined $buf; + fcopy($org,$new) or return if !defined $buf; + chmod scalar((stat($org))[2]), $new if $KeepMode; + $filen++; + } + } + } + 1; + }; + + $recurs->($_zero, $_one, $_[2]) or return; + return wantarray ? ($filen,$dirn,$level) : $filen; +} + +sub fmove { $move->(1, @_) } + +sub rmove { + my $_zero = shift; + $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ) + if substr( $_[0], ( 1 * -1), 1) eq '*'; + + -d $_zero ? dirmove($_zero, @_) : fmove($_zero, @_); +} + +sub dirmove { $move->(0, @_) } + +sub pathmk { + my @parts = File::Spec->splitdir( shift() ); + my $nofatal = shift; + my $pth = $parts[0]; + my $zer = 0; + if(!$pth) { + $pth = File::Spec->catdir($parts[0],$parts[1]); + $zer = 1; + } + for($zer..$#parts) { + mkdir $pth or return if !-d $pth && !$nofatal; + mkdir $pth if !-d $pth && $nofatal; + $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts; + } + 1; +} + +sub pathempty { + my $pth = shift; + return 2 if !-d $pth; + opendir(my $pth_dh, $pth) or return; + for(grep !/^\.+$/, readdir($pth_dh)) { + my $flpth = File::Spec->catdir($pth, $_); + if(-d $flpth) { + pathrmdir($flpth) or return; + } else { + unlink $flpth or return; + } + } + closedir $pth_dh; + 1; +} + +sub pathrm { + my $path = shift; + return 2 if !-d $path; + my @pth = File::Spec->splitdir( $path ); + my $force = shift; + + while(@pth) { + my $cur = File::Spec->catdir(@pth); + last if !$cur; # necessary ??? + if(!shift()) { + pathempty($cur) or return if $force; + rmdir $cur or return; + } else { + pathempty($cur) if $force; + rmdir $cur; + } + pop @pth; + } + 1; +} + +sub pathrmdir { + my $dir = shift; + return 2 if !-d $dir; + pathempty($dir) or return; + rmdir $dir or return; +} + +1; + +__END__ + +=head1 NAME + +File::Copy::Recursive - Perl extension for recursively copying files and directories + +=head1 SYNOPSIS + + use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); + + fcopy($orig,$new[,$buf]) or die $!; + rcopy($orig,$new[,$buf]) or die $!; + dircopy($orig,$new[,$buf]) or die $!; + + fmove($orig,$new[,$buf]) or die $!; + rmove($orig,$new[,$buf]) or die $!; + dirmove($orig,$new[,$buf]) or die $!; + +=head1 DESCRIPTION + +This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode. + +=head1 EXPORT + +None by default. But you can export all the functions as in the example above and the path* functions if you wish. + +=head2 fcopy() + +This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be. +One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below) +The optional $buf in the synopsis if the same as File::Copy::copy()'s 3rd argument +returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomidate rcopy()'s list context on regular files. (See below for more info) + +=head2 dircopy() + +This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory. +$new is created if necessary (multiple non existant directories is ok (IE foo/bar/baz). The script logically and portably creates all of them if necessary). +It attempts to preserve the mode (see Preserving Mode below) and +by default it copies all the way down into the directory, (see Managing Depth) below. +If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified. + +returns true or false, for true in scalar context it returns the number of files and directories copied, +In list context it returns the number of files and directories, number of directories only, depth level traversed. + + my $num_of_files_and_dirs = dircopy($orig,$new); + my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new); + +=head2 rcopy() + +This function will allow you to specify a file *or* directory. It calls fcopy() if its a file and dircopy() if its a directory. +If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. +This is important becasue if its a directory in list context and there is only the initial directory the return value is 1,1,1. + +=head2 fmove() + +Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase. + +=head2 dirmove() + +Copies the directory then removes the original. You can manage the path the original directory is in according to $RemvBase. + +=head2 rmove() + +Like rcopy() but calls fmove() or dirmove() instead. + +=head3 $RemvBase + +Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in. + +So if you: + + rmove('foo/bar/baz', '/etc/'); + # "baz" is removed from foo/bar after it is successfully copied to /etc/ + + $File::Copy::Recursive::Remvbase = 1; + rmove('foo/bar/baz','/etc/'); + # if baz is successfully copied to /etc/ : + # first "baz" is removed from foo/bar + # then "foo/bar is removed via pathrm() + +=head4 $ForcePth + +Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect. + +=head2 Creating and Removing Paths + +=head3 $NoFtlPth + +Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure. + +If its set to true they just silently go about their business regardless. This isn't a good idea but its there if you want it. + +=head3 Path functions + +These functions exist soley because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move funtions work and use them by themselves if you wish. + +=head4 pathrm() + +Removes a given path recursively. It removes the *entire* path so be carefull!!! + +Returns 2 if the given path is not a directory. + + File::Copy::Recursive::pathrm('foo/bar/baz') or die $!; + # foo no longer exists + +Same as: + + rmdir 'foo/bar/baz' or die $!; + rmdir 'foo/bar' or die $!; + rmdir 'foo' or die $!; + +An optional second argument makes it call pathempty() before any rmdir()'s when set to true. + + File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!; + # foo no longer exists + +Same as: + + File::Copy::Recursive::pathempty('foo/bar/baz') or die $!; + rmdir 'foo/bar/baz' or die $!; + File::Copy::Recursive::pathempty('foo/bar/') or die $!; + rmdir 'foo/bar' or die $!; + File::Copy::Recursive::pathempty('foo/') or die $!; + rmdir 'foo' or die $!; + +An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea. + +=head4 pathempty() + +Recursively removes the given directory's contents so it is empty. returns 2 if argument is not a directory, 1 on successfully emptying the directory. + + File::Copy::Recursive::pathempty($pth) or die $!; + # $pth is now an empty directory + +=head4 pathmk() + +Creates a given path recursively. Creates foo/bar/baz even if foo does not exist. + + File::Copy::Recursive::pathmk('foo/bar/baz') or die $!; + +An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea. + +=head4 pathrmdir() + +Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents. +Just removes the top directory the path given insetad of the entire path like pathrm(). Return 2 if the given argument is not a directory. + +=head2 Preserving Mode + +By default a quiet attempt is made to change the new file or directory to the mode of the old one. +To turn this behavior off set + $File::Copy::Recursive::KeepMode +to false; + +=head2 Managing Depth + +You can set the maximum depth a directory structure is recursed by setting: + $File::Copy::Recursive::MaxDepth +to a whole number greater than 0. + +=head2 SymLinks + +If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file. +Perl's symlink() is used instead of File::Copy's copy() +You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value. +It is already set to true or false dending on your system's support of symlinks so you can check it with an if statement to see how it will behave: + + if($File::Copy::Recursive::CopyLink) { + print "Symlinks will be preserved\n"; + } else { + print "Symlinks will not be preserved because your system does not support it\n"; + } + +=head2 Removing existing target file or directory before copying. + +This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively. + +0 = off (This is the default) + +1 = carp() $! if removal fails + +2 = return if removal fails + + local $File::Copy::Recursive::RMTrgFil = 1; + fcopy($orig, $target) or die $!; + # if it fails it does warn() and keeps going + + local $File::Copy::Recursive::RMTrgDir = 2; + dircopy($orig, $target) or die $!; + # if it fails it does your "or die" + +This should be unnecessary most of the time but its there if you need it :) + +=head2 Turning off stat() check + +By default the files or directories are checked to see if they are the same (IE linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. +It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System") + +=head2 Emulating cp -rf dir1/ dir2/ + +By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not. + +You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true. + +NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists. +If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above. + +That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf. +If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf) + +So assuming 'foo/file': + + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/foo/file + +You can also specify a star for cp -rf glob type behavior: + + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + +NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (IE not like cp -rf fo* to copy foo/*) + +=head2 Allowing Copy Loops + +If you want to allow: + + cp -rf . foo/ + +type behavior set $File::Copy::Recursive::CopyLoop to true. + +This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem. + +If you ever find a situation where $CopyLoop = 1 is desirable let me know (IE its a bad bad idea but is there if you want it) + +=head1 SEE ALSO + +L L + +=head1 TO DO + +Add OO interface so you can have different behavior with different objects instead of relying on global variables. +This will give better control in environments where behavior based on global variables is not very desireable. + +I'll add this after the latest verision has been out for a while with no new features or issues found :) + +=head1 AUTHOR + +Daniel Muey, L + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Muey + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Message.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Message.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Message.pm (revision 1098) @@ -0,0 +1,220 @@ +# +# $Id: Message.pm,v 1.25 2001/11/15 06:42:23 gisle Exp $ + +package HTTP::Message; + +=head1 NAME + +HTTP::Message - Class encapsulating HTTP messages + +=head1 SYNOPSIS + + package HTTP::Request; # or HTTP::Response + require HTTP::Message; + @ISA=qw(HTTP::Message); + +=head1 DESCRIPTION + +An C object contains some headers and a content (body). +The class is abstract, i.e. it only used as a base class for +C and C and should never instantiated +as itself. + +The following methods are available: + +=over 4 + +=cut + +##################################################################### + +require HTTP::Headers; +require Carp; +use strict; +use vars qw($VERSION $AUTOLOAD); +$VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/); + +$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI"; +eval "require $HTTP::URI_CLASS"; die $@ if $@; + +=item $mess = HTTP::Message->new + +This is the object constructor. It should only be called internally +by this library. External code should construct C or +C objects. + +=cut + +sub new +{ + my($class, $header, $content) = @_; + if (defined $header) { + Carp::croak("Bad header argument") unless ref $header; + $header = $header->clone; + } else { + $header = HTTP::Headers->new; + } + $content = '' unless defined $content; + bless { + '_headers' => $header, + '_content' => $content, + }, $class; +} + + +=item $mess->clone() + +Returns a copy of the object. + +=cut + +sub clone +{ + my $self = shift; + my $clone = HTTP::Message->new($self->{'_headers'}, $self->{'_content'}); + $clone; +} + +=item $mess->protocol([$proto]) + +Sets the HTTP protocol used for the message. The protocol() is a string +like C or C. + +=cut + +sub protocol { shift->_elem('_protocol', @_); } + +=item $mess->content([$content]) + +The content() method sets the content if an argument is given. If no +argument is given the content is not touched. In either case the +previous content is returned. + +=item $mess->add_content($data) + +The add_content() methods appends more data to the end of the current +content buffer. + +=cut + +sub content { shift->_elem('_content', @_); } + +sub add_content +{ + my $self = shift; + if (ref($_[0])) { + $self->{'_content'} .= ${$_[0]}; # for backwards compatability + } else { + $self->{'_content'} .= $_[0]; + } +} + +=item $mess->content_ref + +The content_ref() method will return a reference to content buffer string. +It can be more efficient to access the content this way if the content +is huge, and it can even be used for direct manipulation of the content, +for instance: + + ${$res->content_ref} =~ s/\bfoo\b/bar/g; + +=cut + +sub content_ref +{ + my $self = shift; + \$self->{'_content'}; +} + +sub as_string +{ + ""; # To be overridden in subclasses +} + +=item $mess->headers; + +Return the embedded HTTP::Headers object. + +=item $mess->headers_as_string([$endl]) + +Call the as_string() method for the headers in the +message. This will be the same as: + + $mess->headers->as_string + +but it will make your program a whole character shorter :-) + +=cut + +sub headers { shift->{'_headers'}; } +sub headers_as_string { shift->{'_headers'}->as_string(@_); } + +=back + +All unknown C methods are delegated to the +C object that is part of every message. This allows +convenient access to these methods. Refer to L for +details of these methods: + + $mess->header($field => $val); + $mess->push_header($field => $val); + $mess->init_header($field => $val); + $mess->remove_header($field); + $mess->scan(\&doit); + + $mess->date; + $mess->expires; + $mess->if_modified_since; + $mess->if_unmodified_since; + $mess->last_modified; + $mess->content_type; + $mess->content_encoding; + $mess->content_length; + $mess->content_language + $mess->title; + $mess->user_agent; + $mess->server; + $mess->from; + $mess->referer; + $mess->www_authenticate; + $mess->authorization; + $mess->proxy_authorization; + $mess->authorization_basic; + $mess->proxy_authorization_basic; + +=cut + + +# delegate all other method calls the the _headers object. +sub AUTOLOAD +{ + my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + return if $method eq "DESTROY"; + + # We create the function here so that it will not need to be + # autoloaded the next time. + no strict 'refs'; + *$method = eval "sub { shift->{'_headers'}->$method(\@_) }"; + goto &$method; +} + +# Private method to access members in %$self +sub _elem +{ + my $self = shift; + my $elem = shift; + my $old = $self->{$elem}; + $self->{$elem} = $_[0] if @_; + return $old; +} + +1; + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Request.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Request.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Request.pm (revision 1098) @@ -0,0 +1,174 @@ +# +# $Id: Request.pm,v 1.30 2001/11/15 06:42:40 gisle Exp $ + +package HTTP::Request; + +=head1 NAME + +HTTP::Request - Class encapsulating HTTP Requests + +=head1 SYNOPSIS + + require HTTP::Request; + $request = HTTP::Request->new(GET => 'http://www.oslo.net/'); + +=head1 DESCRIPTION + +C is a class encapsulating HTTP style requests, +consisting of a request line, some headers, and some (potentially empty) +content. Note that the LWP library also uses this HTTP style requests +for non-HTTP protocols. + +Instances of this class are usually passed to the C method +of an C object: + + $ua = LWP::UserAgent->new; + $request = HTTP::Request->new(GET => 'http://www.oslo.net/'); + $response = $ua->request($request); + +C is a subclass of C and therefore +inherits its methods. The inherited methods most often used are header(), +push_header(), remove_header(), and content(). See L for details. + +The following additional methods are available: + +=over 4 + +=cut + +require HTTP::Message; +@ISA = qw(HTTP::Message); +$VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/); + +use strict; + +=item $r = HTTP::Request->new($method, $uri) + +=item $r = HTTP::Request->new($method, $uri, $header) + +=item $r = HTTP::Request->new($method, $uri, $header, $content) + +Constructs a new C object describing a request on the +object C<$uri> using method C<$method>. The C<$uri> argument can be +either a string, or a reference to a C object. The optional $header +argument should be a reference to an C object. +The optional $content argument should be a string. + +=cut + +sub new +{ + my($class, $method, $uri, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->method($method); + $self->uri($uri); + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->method($self->method); + $clone->uri($self->uri); + $clone; +} + + +=item $r->method([$val]) + +=item $r->uri([$val]) + +These methods provide public access to the attributes containing +respectively the method of the request and the URI object of the +request. + +If an argument is given the attribute is given that as its new +value. If no argument is given the value is not touched. In either +case the previous value is returned. + +The method() method argument should be a string. + +The uri() method accept both a reference to a URI object and a +string as its argument. If a string is given, then it should be +parseable as an absolute URI. + +=cut + +sub method { shift->_elem('_method', @_); } + +sub uri +{ + my $self = shift; + my $old = $self->{'_uri'}; + if (@_) { + my $uri = shift; + if (!defined $uri) { + # that's ok + } elsif (ref $uri) { + Carp::croak("A URI can't be a " . ref($uri) . " reference") + if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY'; + Carp::croak("Can't use a " . ref($uri) . " object as a URI") + unless $uri->can('scheme'); + $uri = $uri->clone; + unless ($HTTP::URI_CLASS eq "URI") { + # Argh!! Hate this... old LWP legacy! + eval { local $SIG{__DIE__}; $uri = $uri->abs; }; + die $@ if $@ && $@ !~ /Missing base argument/; + } + } else { + $uri = $HTTP::URI_CLASS->new($uri); + } + $self->{'_uri'} = $uri; + } + $old; +} + +*url = \&uri; # this is the same for now + +=item $r->as_string() + +Method returning a textual representation of the request. +Mainly useful for debugging purposes. It takes no arguments. + +=cut + +sub as_string +{ + my $self = shift; + my @result; + #push(@result, "---- $self -----"); + my $req_line = $self->method || "[NO METHOD]"; + my $uri = $self->uri; + $uri = (defined $uri) ? $uri->as_string : "[NO URI]"; + $req_line .= " $uri"; + my $proto = $self->protocol; + $req_line .= " $proto" if $proto; + + push(@result, $req_line); + push(@result, $self->headers_as_string); + my $content = $self->content; + if (defined $content) { + push(@result, $content); + } + #push(@result, ("-" x 40)); + join("\n", @result, ""); +} + +1; + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Headers.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Headers.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Headers.pm (revision 1098) @@ -0,0 +1,615 @@ +package HTTP::Headers; + +# $Id: Headers.pm,v 1.43 2001/11/15 06:19:22 gisle Exp $ + +=head1 NAME + +HTTP::Headers - Class encapsulating HTTP Message headers + +=head1 SYNOPSIS + + require HTTP::Headers; + $h = HTTP::Headers->new; + + $h->header('Content-Type' => 'text/plain'); # set + $ct = $h->header('Content-Type'); # get + $h->remove_header('Content-Type'); # delete + +=head1 DESCRIPTION + +The C class encapsulates HTTP-style message headers. +The headers consist of attribute-value pairs also called fields, which +may be repeated, and which are printed in a particular order. + +Instances of this class are usually created as member variables of the +C and C classes, internal to the +library. + +The following methods are available: + +=over 4 + +=cut + +use strict; +use Carp (); + +use vars qw($VERSION $TRANSLATE_UNDERSCORE); +$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/); + +# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used +# as a replacement for '-' in header field names. +$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE; + +# "Good Practice" order of HTTP message headers: +# - General-Headers +# - Request-Headers +# - Response-Headers +# - Entity-Headers + +my @header_order = qw( + Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade + Via Warning + + Accept Accept-Charset Accept-Encoding Accept-Language + Authorization Expect From Host + If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since + Max-Forwards Proxy-Authorization Range Referer TE User-Agent + + Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server + Vary WWW-Authenticate + + Allow Content-Encoding Content-Language Content-Length Content-Location + Content-MD5 Content-Range Content-Type Expires Last-Modified +); + +# Make alternative representations of @header_order. This is used +# for sorting and case matching. +my %header_order; +my %standard_case; + +{ + my $i = 0; + for (@header_order) { + my $lc = lc $_; + $header_order{$lc} = ++$i; + $standard_case{$lc} = $_; + } +} + + + + +=item $h = HTTP::Headers->new + +Constructs a new C object. You might pass some initial +attribute-value pairs as parameters to the constructor. I: + + $h = HTTP::Headers->new( + Date => 'Thu, 03 Feb 1994 00:00:00 GMT', + Content_Type => 'text/html; version=3.2', + Content_Base => 'http://www.perl.org/'); + +The constructor arguments are passed to the C
method which is +described below. + +=cut + +sub new +{ + my($class) = shift; + my $self = bless {}, $class; + $self->header(@_); # set up initial headers + $self; +} + + +=item $h->header($field [=> $value],...) + +Get or set the value of one or more header fields. The header field name +($field) is not case sensitive. To make the life easier for perl +users who wants to avoid quoting before the => operator, you can use +'_' as a replacement for '-' in header names (this behaviour can be +suppressed by setting the $HTTP::Headers::TRANSLATE_UNDERSCORE +variable to a FALSE value). + +The header() method accepts multiple ($field => $value) pairs, which +means that you can update several fields with a single invocation. + +The $value argument may be a plain string or a reference to an array +of strings for a multi-valued field. If the $value is undefined or not +given, then that header field will remain unchanged. + +The old value (or values) of the last of the header fields is returned. +If no such field exists C will be returned. + +A multi-valued field will be retuned as separate values in list +context and will be concatenated with ", " as separator in scalar +context. The HTTP spec (RFC 2616) promise that joining multiple +values in this way will not change the semantic of a header field, but +in practice there are cases like old-style Netscape cookies (see +L) where "," is used as part of the syntax of a single +field value. + +Examples: + + $header->header(MIME_Version => '1.0', + User_Agent => 'My-Web-Client/0.01'); + $header->header(Accept => "text/html, text/plain, image/*"); + $header->header(Accept => [qw(text/html text/plain image/*)]); + @accepts = $header->header('Accept'); # get multiple values + $accepts = $header->header('Accept'); # get values as a single string + +=cut + +sub header +{ + my $self = shift; + my(@old); + while (my($field, $val) = splice(@_, 0, 2)) { + @old = $self->_header($field, $val); + } + return @old if wantarray; + return $old[0] if @old <= 1; + join(", ", @old); +} + + +=item $h->push_header($field, $value) + +Add a new field value for the specified header field. Previous values +for the same field are retained. + +As for the header() method, the field name ($field) is not case +sensitive and '_' can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + + $header->push_header(Accept => 'image/jpeg'); + $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]); + +=cut + +sub push_header +{ + Carp::croak('Usage: $h->push_header($field, $val)') if @_ != 3; + shift->_header(@_, 'PUSH'); +} + +=item $h->init_header($field, $value) + +Set the specified header to the given value, but only if no previous +value for that field is set. + +The header field name ($field) is not case sensitive and '_' +can be used as a replacement for '-'. + +The $value argument may be a scalar or a reference to a list of +scalars. + +=cut + +sub init_header +{ + Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; + shift->_header(@_, 'INIT'); +} + + +=item $h->remove_header($field,...) + +This function removes the headers fields with the specified names. + +The header field names ($field) are not case sensitive and '_' +can be used as a replacement for '-'. + +The return value is the values of the fields removed. In scalar +context the number of fields removed is returned. + +Note that if you pass in multiple field names then it is generally not +possible to tell which of the returned values belonged to which field. + +=cut + +sub remove_header +{ + my($self, @fields) = @_; + my $field; + my @values; + foreach $field (@fields) { + $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; + my $v = delete $self->{lc $field}; + push(@values, ref($v) ? @$v : $v) if defined $v; + } + return @values; +} + + +sub _header +{ + my($self, $field, $val, $op) = @_; + $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; + + # $push is only used interally sub push_header + Carp::croak('Need a field name') unless length($field); + + my $lc_field = lc $field; + unless(defined $standard_case{$lc_field}) { + # generate a %standard_case entry for this field + $field =~ s/\b(\w)/\u$1/g; + $standard_case{$lc_field} = $field; + } + + my $h = $self->{$lc_field}; + my @old = ref($h) ? @$h : (defined($h) ? ($h) : ()); + + $op ||= ""; + $val = undef if $op eq 'INIT' && @old; + if (defined($val)) { + my @new = ($op eq 'PUSH') ? @old : (); + if (!ref($val)) { + push(@new, $val); + } elsif (ref($val) eq 'ARRAY') { + push(@new, @$val); + } else { + Carp::croak("Unexpected field value $val"); + } + $self->{$lc_field} = @new > 1 ? \@new : $new[0]; + } + @old; +} + + +# Compare function which makes it easy to sort headers in the +# recommended "Good Practice" order. +sub _header_cmp +{ + ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || $a cmp $b; +} + + +=item $h->scan(\&doit) + +Apply a subroutine to each header field in turn. The callback routine +is called with two parameters; the name of the field and a single +value (a string). If a header field is multi-valued, then the +routine is called once for each value. The field name passed to the +callback routine has case as suggested by HTTP spec, and the headers +will be visited in the recommended "Good Practice" order. + +Any return values of the callback routine are ignored. The loop can +be broken by raising an exception (C). + +=cut + +sub scan +{ + my($self, $sub) = @_; + my $key; + foreach $key (sort _header_cmp keys %$self) { + next if $key =~ /^_/; + my $vals = $self->{$key}; + if (ref($vals)) { + my $val; + for $val (@$vals) { + &$sub($standard_case{$key} || $key, $val); + } + } else { + &$sub($standard_case{$key} || $key, $vals); + } + } +} + + +=item $h->as_string([$endl]) + +Return the header fields as a formatted MIME header. Since it +internally uses the C method to build the string, the result +will use case as suggested by HTTP spec, and it will follow +recommended "Good Practice" of ordering the header fieds. Long header +values are not folded. + +The optional $endl parameter specifies the line ending sequence to +use. The default is "\n". Embedded "\n" characters in header field +values will be substitued with this line ending sequence. + +=cut + +sub as_string +{ + my($self, $endl) = @_; + $endl = "\n" unless defined $endl; + + my @result = (); + $self->scan(sub { + my($field, $val) = @_; + if ($val =~ /\n/) { + # must handle header values with embedded newlines with care + $val =~ s/\s+$//; # trailing newlines and space must go + $val =~ s/\n\n+/\n/g; # no empty lines + $val =~ s/\n([^\040\t])/\n $1/g; # intial space for continuation + $val =~ s/\n/$endl/g; # substitute with requested line ending + } + push(@result, "$field: $val"); + }); + + join($endl, @result, ''); +} + + +=item $h->clone + +Returns a copy of this C object. + +=back + +=cut + +sub clone +{ + my $self = shift; + my $clone = new HTTP::Headers; + $self->scan(sub { $clone->push_header(@_);} ); + $clone; +} + + +=head1 CONVENIENCE METHODS + +The most frequently used headers can also be accessed through the +following convenience methods. These methods can both be used to read +and to set the value of a header. The header value is set if you pass +an argument to the method. The old header value is always returned. +If the given header did not exists then C is returned. + +Methods that deal with dates/times always convert their value to system +time (seconds since Jan 1, 1970) and they also expect this kind of +value when the header value is set. + +=over 4 + +=item $h->date + +This header represents the date and time at which the message was +originated. I: + + $h->date(time); # set current date + +=item $h->expires + +This header gives the date and time after which the entity should be +considered stale. + +=item $h->if_modified_since + +=item $h->if_unmodified_since + +These header fields are used to make a request conditional. If the requested +resource has (or has not) been modified since the time specified in this field, +then the server will return a C<304 Not Modified> response instead of +the document itself. + +=item $h->last_modified + +This header indicates the date and time at which the resource was last +modified. I: + + # check if document is more than 1 hour old + if (my $last_mod = $h->last_modified) { + if ($last_mod < time - 60*60) { + ... + } + } + +=item $h->content_type + +The Content-Type header field indicates the media type of the message +content. I: + + $h->content_type('text/html'); + +The value returned will be converted to lower case, and potential +parameters will be chopped off and returned as a separate value if in +an array context. This makes it safe to do the following: + + if ($h->content_type eq 'text/html') { + # we enter this place even if the real header value happens to + # be 'TEXT/HTML; version=3.0' + ... + } + +=item $h->content_encoding + +The Content-Encoding header field is used as a modifier to the +media type. When present, its value indicates what additional +encoding mechanism has been applied to the resource. + +=item $h->content_length + +A decimal number indicating the size in bytes of the message content. + +=item $h->content_language + +The natural language(s) of the intended audience for the message +content. The value is one or more language tags as defined by RFC +1766. Eg. "no" for some kind of Norwegian and "en-US" for English the +way it is written in the US. + +=item $h->title + +The title of the document. In libwww-perl this header will be +initialized automatically from the ETITLE>...E/TITLE> element +of HTML documents. I + +=item $h->user_agent + +This header field is used in request messages and contains information +about the user agent originating the request. I: + + $h->user_agent('Mozilla/1.2'); + +=item $h->server + +The server header field contains information about the software being +used by the originating server program handling the request. + +=item $h->from + +This header should contain an Internet e-mail address for the human +user who controls the requesting user agent. The address should be +machine-usable, as defined by RFC822. E.g.: + + $h->from('King Kong '); + +I + +=item $h->referer + +Used to specify the address (URI) of the document from which the +requested resouce address was obtained. + +The "Free On-line Dictionary of Computing" as this to say about the +word I: + + A misspelling of "referrer" which + somehow made it into the {HTTP} standard. A given {web + page}'s referer (sic) is the {URL} of whatever web page + contains the link that the user followed to the current + page. Most browsers pass this information as part of a + request. + + (1998-10-19) + +By popular demand C exists as an alias for this method so you +can avoid this misspelling in your programs and still send the right +thing on the wire. + + +=item $h->www_authenticate + +This header must be included as part of a C<401 Unauthorized> response. +The field value consist of a challenge that indicates the +authentication scheme and parameters applicable to the requested URI. + +=item $h->proxy_authenticate + +This header must be included in a C<407 Proxy Authentication Required> +response. + +=item $h->authorization + +=item $h->proxy_authorization + +A user agent that wishes to authenticate itself with a server or a +proxy, may do so by including these headers. + +=item $h->authorization_basic + +This method is used to get or set an authorization header that use the +"Basic Authentication Scheme". In array context it will return two +values; the user name and the password. In scalar context it will +return I<"uname:password"> as a single string value. + +When used to set the header value, it expects two arguments. I: + + $h->authorization_basic($uname, $password); + +The method will croak if the $uname contains a colon ':'. + +=item $h->proxy_authorization_basic + +Same as authorization_basic() but will set the "Proxy-Authorization" +header instead. + +=back + +=cut + +sub _date_header +{ + require HTTP::Date; + my($self, $header, $time) = @_; + my($old) = $self->_header($header); + if (defined $time) { + $self->_header($header, HTTP::Date::time2str($time)); + } + HTTP::Date::str2time($old); +} + +sub date { shift->_date_header('Date', @_); } +sub expires { shift->_date_header('Expires', @_); } +sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } +sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } +sub last_modified { shift->_date_header('Last-Modified', @_); } + +# This is used as a private LWP extention. The Client-Date header is +# added as a timestamp to a response when it has been received. +sub client_date { shift->_date_header('Client-Date', @_); } + +# The retry_after field is dual format (can also be a expressed as +# number of seconds from now), so we don't provide an easy way to +# access it until we have know how both these interfaces can be +# addressed. One possibility is to return a negative value for +# relative seconds and a positive value for epoch based time values. +#sub retry_after { shift->_date_header('Retry-After', @_); } + +sub content_type { + my $ct = (shift->_header('Content-Type', @_))[0]; + return '' unless defined($ct) && length($ct); + my @ct = split(/\s*;\s*/, lc($ct)); + wantarray ? @ct : $ct[0]; +} + +sub title { (shift->_header('Title', @_))[0] } +sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } +sub content_language { (shift->_header('Content-Language', @_))[0] } +sub content_length { (shift->_header('Content-Length', @_))[0] } + +sub user_agent { (shift->_header('User-Agent', @_))[0] } +sub server { (shift->_header('Server', @_))[0] } + +sub from { (shift->_header('From', @_))[0] } +sub referer { (shift->_header('Referer', @_))[0] } +*referrer = \&referer; # on tchrist's request +sub warning { (shift->_header('Warning', @_))[0] } + +sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } +sub authorization { (shift->_header('Authorization', @_))[0] } + +sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } +sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } + +sub authorization_basic { shift->_basic_auth("Authorization", @_) } +sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } + +sub _basic_auth { + require MIME::Base64; + my($self, $h, $user, $passwd) = @_; + my($old) = $self->_header($h); + if (defined $user) { + Carp::croak("Basic authorization user name can't contain ':'") + if $user =~ /:/; + $passwd = '' unless defined $passwd; + $self->_header($h => 'Basic ' . + MIME::Base64::encode("$user:$passwd", '')); + } + if (defined $old && $old =~ s/^\s*Basic\s+//) { + my $val = MIME::Base64::decode($old); + return $val unless wantarray; + return split(/:/, $val, 2); + } + return; +} + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; Index: /branches/mt4.11/extlib/HTTP/Cookies.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Cookies.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Cookies.pm (revision 1098) @@ -0,0 +1,804 @@ +package HTTP::Cookies; + +use strict; +use HTTP::Date qw(str2time time2str); +use HTTP::Headers::Util qw(split_header_words join_header_words); +use LWP::Debug (); + +use vars qw($VERSION); +$VERSION = sprintf("%d.%02d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/); + +my $EPOCH_OFFSET = 0; # difference from Unix epoch +if ($^O eq "MacOS") { + require Time::Local; + $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70); +} + +=head1 NAME + +HTTP::Cookies - Cookie storage and management + +=head1 SYNOPSIS + + use HTTP::Cookies; + $cookie_jar = HTTP::Cookies->new; + + $cookie_jar->add_cookie_header($request); + $cookie_jar->extract_cookies($response); + +=head1 DESCRIPTION + +Cookies are a general mechanism which server side connections can use +to both store and retrieve information on the client side of the +connection. For more information about cookies refer to + and +. This module also implements the +new style cookies described in I. +The two variants of cookies are supposed to be able to coexist happily. + +Instances of the class I are able to store a collection +of Set-Cookie2: and Set-Cookie: headers and are able to use this +information to initialize Cookie-headers in I objects. +The state of a I object can be saved in and restored from +files. + +=head1 METHODS + +The following methods are provided: + +=over 4 + +=cut + +# A HTTP::Cookies object is a hash. The main attribute is the +# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}. + + +=item $cookie_jar = HTTP::Cookies->new; + +The constructor takes hash style parameters. The following +parameters are recognized: + + file: name of the file to restore cookies from and save cookies to + autosave: save during destruction (bool) + ignore_discard: save even cookies that are requested to be discarded (bool) + hide_cookie2: don't add Cookie2 header to requests + +Future parameters might include (not yet implemented): + + max_cookies 300 + max_cookies_per_domain 20 + max_cookie_size 4096 + + no_cookies list of domain names that we never return cookies to + +=cut + +sub new +{ + my $class = shift; + my $self = bless { + COOKIES => {}, + }, $class; + my %cnf = @_; + for (keys %cnf) { + $self->{lc($_)} = $cnf{$_}; + } + $self->load; + $self; +} + + +=item $cookie_jar->add_cookie_header($request); + +The add_cookie_header() method will set the appropriate Cookie:-header +for the I object given as argument. The $request must +have a valid url attribute before this method is called. + +=cut + +sub add_cookie_header +{ + my $self = shift; + my $request = shift || return; + my $url = $request->url; + my $domain = _host($request, $url); + $domain = "$domain.local" unless $domain =~ /\./; + my $secure_request = ($url->scheme eq "https"); + my $req_path = _url_path($url); + my $req_port = $url->port; + my $now = time(); + _normalize_path($req_path) if $req_path =~ /%/; + + my @cval; # cookie values for the "Cookie" header + my $set_ver; + my $netscape_only = 0; # An exact domain match applies to any cookie + + while ($domain =~ /\./) { + + LWP::Debug::debug("Checking $domain for cookies"); + my $cookies = $self->{COOKIES}{$domain}; + next unless $cookies; + + # Want to add cookies corresponding to the most specific paths + # first (i.e. longest path first) + my $path; + for $path (sort {length($b) <=> length($a) } keys %$cookies) { + LWP::Debug::debug("- checking cookie path=$path"); + if (index($req_path, $path) != 0) { + LWP::Debug::debug(" path $path:$req_path does not fit"); + next; + } + + my($key,$array); + while (($key,$array) = each %{$cookies->{$path}}) { + my($version,$val,$port,$path_spec,$secure,$expires) = @$array; + LWP::Debug::debug(" - checking cookie $key=$val"); + if ($secure && !$secure_request) { + LWP::Debug::debug(" not a secure requests"); + next; + } + if ($expires && $expires < $now) { + LWP::Debug::debug(" expired"); + next; + } + if ($port) { + my $found; + if ($port =~ s/^_//) { + # The correponding Set-Cookie attribute was empty + $found++ if $port eq $req_port; + $port = ""; + } else { + my $p; + for $p (split(/,/, $port)) { + $found++, last if $p eq $req_port; + } + } + unless ($found) { + LWP::Debug::debug(" port $port:$req_port does not fit"); + next; + } + } + if ($version > 0 && $netscape_only) { + LWP::Debug::debug(" domain $domain applies to " . + "Netscape-style cookies only"); + next; + } + + LWP::Debug::debug(" it's a match"); + + # set version number of cookie header. + # XXX: What should it be if multiple matching + # Set-Cookie headers have different versions themselves + if (!$set_ver++) { + if ($version >= 1) { + push(@cval, "\$Version=$version"); + } elsif (!$self->{hide_cookie2}) { + $request->header(Cookie2 => '$Version="1"'); + } + } + + # do we need to quote the value + if ($val =~ /\W/ && $version) { + $val =~ s/([\\\"])/\\$1/g; + $val = qq("$val"); + } + + # and finally remember this cookie + push(@cval, "$key=$val"); + if ($version >= 1) { + push(@cval, qq(\$Path="$path")) if $path_spec; + push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./; + if (defined $port) { + my $p = '$Port'; + $p .= qq(="$port") if length $port; + push(@cval, $p); + } + } + + } + } + + } continue { + # Try with a more general domain, alternately stripping + # leading name components and leading dots. When this + # results in a domain with no leading dot, it is for + # Netscape cookie compatibility only: + # + # a.b.c.net Any cookie + # .b.c.net Any cookie + # b.c.net Netscape cookie only + # .c.net Any cookie + + if ($domain =~ s/^\.+//) { + $netscape_only = 1; + } else { + $domain =~ s/[^.]*//; + $netscape_only = 0; + } + } + + $request->header(Cookie => join("; ", @cval)) if @cval; + + $request; +} + + +=item $cookie_jar->extract_cookies($response); + +The extract_cookies() method will look for Set-Cookie: and +Set-Cookie2: headers in the I object passed as +argument. Any of these headers that are found are used to update +the state of the $cookie_jar. + +=cut + +sub extract_cookies +{ + my $self = shift; + my $response = shift || return; + + my @set = split_header_words($response->_header("Set-Cookie2")); + my @ns_set = $response->_header("Set-Cookie"); + + return $response unless @set || @ns_set; # quick exit + + my $request = $response->request; + my $url = $request->url; + my $req_host = _host($request, $url); + $req_host = "$req_host.local" unless $req_host =~ /\./; + my $req_port = $url->port; + my $req_path = _url_path($url); + _normalize_path($req_path) if $req_path =~ /%/; + + if (@ns_set) { + # The old Netscape cookie format for Set-Cookie + # http://www.netscape.com/newsref/std/cookie_spec.html + # can for instance contain an unquoted "," in the expires + # field, so we have to use this ad-hoc parser. + my $now = time(); + + # Build a hash of cookies that was present in Set-Cookie2 + # headers. We need to skip them if we also find them in a + # Set-Cookie header. + my %in_set2; + for (@set) { + $in_set2{$_->[0]}++; + } + + my $set; + for $set (@ns_set) { + my @cur; + my $param; + my $expires; + for $param (split(/;\s*/, $set)) { + my($k,$v) = split(/\s*=\s*/, $param, 2); + $v =~ s/\s+$//; + #print "$k => $v\n"; + my $lc = lc($k); + if ($lc eq "expires") { + my $etime = str2time($v); + if ($etime) { + push(@cur, "Max-Age" => str2time($v) - $now); + $expires++; + } + } else { + push(@cur, $k => $v); + } + } + next if $in_set2{$cur[0]}; + +# push(@cur, "Port" => $req_port); + push(@cur, "Discard" => undef) unless $expires; + push(@cur, "Version" => 0); + push(@cur, "ns-cookie" => 1); + push(@set, \@cur); + } + } + + SET_COOKIE: + for my $set (@set) { + next unless @$set >= 2; + + my $key = shift @$set; + my $val = shift @$set; + + LWP::Debug::debug("Set cookie $key => $val"); + + my %hash; + while (@$set) { + my $k = shift @$set; + my $v = shift @$set; + my $lc = lc($k); + # don't loose case distinction for unknown fields + $k = $lc if $lc =~ /^(?:discard|domain|max-age| + path|port|secure|version)$/x; + if ($k eq "discard" || $k eq "secure") { + $v = 1 unless defined $v; + } + next if exists $hash{$k}; # only first value is signigicant + $hash{$k} = $v; + }; + + my %orig_hash = %hash; + my $version = delete $hash{version}; + $version = 1 unless defined($version); + my $discard = delete $hash{discard}; + my $secure = delete $hash{secure}; + my $maxage = delete $hash{'max-age'}; + my $ns_cookie = delete $hash{'ns-cookie'}; + + # Check domain + my $domain = delete $hash{domain}; + if (defined($domain) + && $domain ne $req_host && $domain ne ".$req_host") { + if ($domain !~ /\./ && $domain ne "local") { + LWP::Debug::debug("Domain $domain contains no dot"); + next SET_COOKIE; + } + $domain = ".$domain" unless $domain =~ /^\./; + if ($domain =~ /\.\d+$/) { + LWP::Debug::debug("IP-address $domain illeagal as domain"); + next SET_COOKIE; + } + my $len = length($domain); + unless (substr($req_host, -$len) eq $domain) { + LWP::Debug::debug("Domain $domain does not match host $req_host"); + next SET_COOKIE; + } + my $hostpre = substr($req_host, 0, length($req_host) - $len); + if ($hostpre =~ /\./ && !$ns_cookie) { + LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain"); + next SET_COOKIE; + } + } else { + $domain = $req_host; + } + + my $path = delete $hash{path}; + my $path_spec; + if (defined $path && $path ne '') { + $path_spec++; + _normalize_path($path) if $path =~ /%/; + if (!$ns_cookie && + substr($req_path, 0, length($path)) ne $path) { + LWP::Debug::debug("Path $path is not a prefix of $req_path"); + next SET_COOKIE; + } + } else { + $path = $req_path; + $path =~ s,/[^/]*$,,; + $path = "/" unless length($path); + } + + my $port; + if (exists $hash{port}) { + $port = delete $hash{port}; + if (defined $port) { + $port =~ s/\s+//g; + my $found; + for my $p (split(/,/, $port)) { + unless ($p =~ /^\d+$/) { + LWP::Debug::debug("Bad port $port (not numeric)"); + next SET_COOKIE; + } + $found++ if $p eq $req_port; + } + unless ($found) { + LWP::Debug::debug("Request port ($req_port) not found in $port"); + next SET_COOKIE; + } + } else { + $port = "_$req_port"; + } + } + $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash) + if $self->set_cookie_ok(\%orig_hash); + } + + $response; +} + +sub set_cookie_ok { 1 }; + +=item $cookie_jar->set_cookie($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest) + +The set_cookie() method updates the state of the $cookie_jar. The +$key, $val, $domain, $port and $path arguments are strings. The +$path_spec, $secure, $discard arguments are boolean values. The $maxage +value is a number indicating number of seconds that this cookie will +live. A value <= 0 will delete this cookie. %rest defines +various other attributes like "Comment" and "CommentURL". + +=cut + +sub set_cookie +{ + my $self = shift; + my($version, + $key, $val, $path, $domain, $port, + $path_spec, $secure, $maxage, $discard, $rest) = @_; + + # path and key can not be empty (key can't start with '$') + return $self if !defined($path) || $path !~ m,^/, || + !defined($key) || $key !~ m,[^\$],; + + # ensure legal port + if (defined $port) { + return $self unless $port =~ /^_?\d+(?:,\d+)*$/; + } + + my $expires; + if (defined $maxage) { + if ($maxage <= 0) { + delete $self->{COOKIES}{$domain}{$path}{$key}; + return $self; + } + $expires = time() + $maxage; + } + $version = 0 unless defined $version; + + my @array = ($version, $val,$port, + $path_spec, + $secure, $expires, $discard); + push(@array, {%$rest}) if defined($rest) && %$rest; + # trim off undefined values at end + pop(@array) while !defined $array[-1]; + + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + $self; +} + +=item $cookie_jar->save( [$file] ); + +This method file saves the state of the $cookie_jar to a file. +The state can then be restored later using the load() method. If a +filename is not specified we will use the name specified during +construction. If the attribute I is set, then we +will even save cookies that are marked to be discarded. + +The default is to save a sequence of "Set-Cookie3" lines. +"Set-Cookie3" is a proprietary LWP format, not known to be compatible +with any browser. The I sub-class can +be used to save in a format compatible with Netscape. + +=cut + +sub save +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + local(*FILE); + open(FILE, ">$file") or die "Can't open $file: $!"; + print FILE "#LWP-Cookies-1.0\n"; + print FILE $self->as_string(!$self->{ignore_discard}); + close(FILE); + 1; +} + +=item $cookie_jar->load( [$file] ); + +This method reads the cookies from the file and adds them to the +$cookie_jar. The file must be in the format written by the save() +method. + +=cut + +sub load +{ + my $self = shift; + my $file = shift || $self->{'file'} || return; + local(*FILE, $_); + local $/ = "\n"; # make sure we got standard record separator + open(FILE, $file) or return; + my $magic = ; + unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) { + warn "$file does not seem to contain cookies"; + return; + } + while () { + next unless s/^Set-Cookie3:\s*//; + chomp; + my $cookie; + for $cookie (split_header_words($_)) { + my($key,$val) = splice(@$cookie, 0, 2); + my %hash; + while (@$cookie) { + my $k = shift @$cookie; + my $v = shift @$cookie; + $hash{$k} = $v; + } + my $version = delete $hash{version}; + my $path = delete $hash{path}; + my $domain = delete $hash{domain}; + my $port = delete $hash{port}; + my $expires = str2time(delete $hash{expires}); + + my $path_spec = exists $hash{path_spec}; delete $hash{path_spec}; + my $secure = exists $hash{secure}; delete $hash{secure}; + my $discard = exists $hash{discard}; delete $hash{discard}; + + my @array = ($version,$val,$port, + $path_spec,$secure,$expires,$discard); + push(@array, \%hash) if %hash; + $self->{COOKIES}{$domain}{$path}{$key} = \@array; + } + } + close(FILE); + 1; +} + +=item $cookie_jar->revert; + +This method empties the $cookie_jar and re-loads the $cookie_jar +from the last save file. + +=cut + +sub revert +{ + my $self = shift; + $self->clear->load; + $self; +} + +=item $cookie_jar->clear( [$domain, [$path, [$key] ] ]); + +Invoking this method without arguments will empty the whole +$cookie_jar. If given a single argument only cookies belonging to +that domain will be removed. If given two arguments, cookies +belonging to the specified path within that domain are removed. If +given three arguments, then the cookie with the specified key, path +and domain is removed. + +=cut + +sub clear +{ + my $self = shift; + if (@_ == 0) { + $self->{COOKIES} = {}; + } elsif (@_ == 1) { + delete $self->{COOKIES}{$_[0]}; + } elsif (@_ == 2) { + delete $self->{COOKIES}{$_[0]}{$_[1]}; + } elsif (@_ == 3) { + delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]}; + } else { + require Carp; + Carp::carp('Usage: $c->clear([domain [,path [,key]]])'); + } + $self; +} + +=item $cookie_jar->clear_temporary_cookies( ); + +Discard all temporary cookies. Scans for all cookies in the jar +with either no expire field or a true C flag. To be +called when the user agent shuts down according to RFC 2965. + +=cut + +sub clear_temporary_cookies +{ + my($self) = @_; + + $self->scan(sub { + if($_[9] or # "Discard" flag set + not $_[8]) { # No expire field? + $_[8] = -1; # Set the expire/max_age field + $self->set_cookie(@_); # Clear the cookie + } + }); +} + +sub DESTROY +{ + my $self = shift; + $self->save if $self->{'autosave'}; +} + + +=item $cookie_jar->scan( \&callback ); + +The argument is a subroutine that will be invoked for each cookie +stored in the $cookie_jar. The subroutine will be invoked with +the following arguments: + + 0 version + 1 key + 2 val + 3 path + 4 domain + 5 port + 6 path_spec + 7 secure + 8 expires + 9 discard + 10 hash + +=cut + +sub scan +{ + my($self, $cb) = @_; + my($domain,$path,$key); + for $domain (sort keys %{$self->{COOKIES}}) { + for $path (sort keys %{$self->{COOKIES}{$domain}}) { + for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) { + my($version,$val,$port,$path_spec, + $secure,$expires,$discard,$rest) = + @{$self->{COOKIES}{$domain}{$path}{$key}}; + $rest = {} unless defined($rest); + &$cb($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest); + } + } + } +} + +=item $cookie_jar->as_string( [$skip_discard] ); + +The as_string() method will return the state of the $cookie_jar +represented as a sequence of "Set-Cookie3" header lines separated by +"\n". If $skip_discard is TRUE, it will not return lines for +cookies with the I attribute. + +=cut + +sub as_string +{ + my($self, $skip_discard) = @_; + my @res; + $self->scan(sub { + my($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest) = @_; + return if $discard && $skip_discard; + my @h = ($key, $val); + push(@h, "path", $path); + push(@h, "domain" => $domain); + push(@h, "port" => $port) if defined $port; + push(@h, "path_spec" => undef) if $path_spec; + push(@h, "secure" => undef) if $secure; + push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires; + push(@h, "discard" => undef) if $discard; + my $k; + for $k (sort keys %$rest) { + push(@h, $k, $rest->{$k}); + } + push(@h, "version" => $version); + push(@res, "Set-Cookie3: " . join_header_words(\@h)); + }); + join("\n", @res, ""); +} + +sub _host +{ + my($request, $url) = @_; + if (my $h = $request->header("Host")) { + $h =~ s/:\d+$//; # might have a port as well + return $h; + } + return $url->host; +} + +sub _url_path +{ + my $url = shift; + my $path; + if($url->can('epath')) { + $path = $url->epath; # URI::URL method + } else { + $path = $url->path; # URI::_generic method + } + $path = "/" unless length $path; + $path; +} + +sub _normalize_path # so that plain string compare can be used +{ + my $x; + $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/ + $x = uc($1); + $x eq "2F" || $x eq "25" ? "%$x" : + pack("C", hex($x)); + /eg; + $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg; +} + + + +=back + +=head1 SUB CLASSES + +We also provide a subclass called I which +loads and saves Netscape compatible cookie files. You +should be able to have LWP share Netscape's cookies by constructing +your $cookie_jar like this: + + $cookie_jar = HTTP::Cookies::Netscape->new( + File => "$ENV{HOME}/.netscape/cookies", + AutoSave => 1, + ); + +Please note that the Netscape cookie file format is not able to store +all the information available in the Set-Cookie2 headers, so you will +probably loose some information if you save in this format. + +=cut + +package HTTP::Cookies::Netscape; + +use vars qw(@ISA); +@ISA=qw(HTTP::Cookies); + +sub load +{ + my($self, $file) = @_; + $file ||= $self->{'file'} || return; + local(*FILE, $_); + local $/ = "\n"; # make sure we got standard record separator + my @cookies; + open(FILE, $file) || return; + my $magic = ; + unless ($magic =~ /^\# Netscape HTTP Cookie File/) { + warn "$file does not look like a netscape cookies file" if $^W; + close(FILE); + return; + } + my $now = time() - $EPOCH_OFFSET; + while () { + next if /^\s*\#/; + next if /^\s*$/; + chomp; + my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_); + $secure = ($secure eq "TRUE"); + $self->set_cookie(undef,$key,$val,$path,$domain,undef, + 0,$secure,$expires-$now, 0); + } + close(FILE); + 1; +} + +sub save +{ + my($self, $file) = @_; + $file ||= $self->{'file'} || return; + local(*FILE, $_); + open(FILE, ">$file") || return; + + print FILE <scan(sub { + my($version,$key,$val,$path,$domain,$port, + $path_spec,$secure,$expires,$discard,$rest) = @_; + return if $discard && !$self->{ignore_discard}; + $expires = $expires ? $expires - $EPOCH_OFFSET : 0; + return if $now > $expires; + $secure = $secure ? "TRUE" : "FALSE"; + my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; + print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n"; + }); + close(FILE); + 1; +} + +1; + +__END__ + +=head1 COPYRIGHT + +Copyright 1997-1999 Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Date.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Date.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Date.pm (revision 1098) @@ -0,0 +1,386 @@ +package HTTP::Date; # $Date: 2001/01/04 20:27:15 $ + +$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/); + +require 5.004; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(time2str str2time); +@EXPORT_OK = qw(parse_date time2iso time2isoz); + +use strict; +require Time::Local; + +use vars qw(@DoW @MoY %MoY); +@DoW = qw(Sun Mon Tue Wed Thu Fri Sat); +@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +@MoY{@MoY} = (1..12); + +my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1); + + +sub time2str (;$) +{ + my $time = shift; + $time = time unless defined $time; + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time); + sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", + $DoW[$wday], + $mday, $MoY[$mon], $year+1900, + $hour, $min, $sec); +} + + +sub str2time ($;$) +{ + my $str = shift; + return undef unless defined $str; + + # fast exit for strictly conforming string + if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) { + return eval { + my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3-1900); + $t < 0 ? undef : $t; + }; + } + + my @d = parse_date($str); + return undef unless @d; + $d[0] -= 1900; # year + $d[1]--; # month + + my $tz = pop(@d); + unless (defined $tz) { + unless (defined($tz = shift)) { + return eval { my $t = Time::Local::timelocal(reverse @d); + $t < 0 ? undef : $t; + }; + } + } + + my $offset = 0; + if ($GMT_ZONE{uc $tz}) { + # offset already zero + } + elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) { + $offset = 3600 * $2; + $offset += 60 * $3 if $3; + $offset *= -1 if $1 && $1 eq '-'; + } + else { + eval { require Time::Zone } || return undef; + $offset = Time::Zone::tz_offset($tz); + return undef unless defined $offset; + } + + return eval { my $t = Time::Local::timegm(reverse @d); + $t < 0 ? undef : $t - $offset; + }; +} + + +sub parse_date ($) +{ + local($_) = shift; + return unless defined; + + # More lax parsing below + s/^\s+//; # kill leading space + s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday + + my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm); + + # Then we are able to check for most of the formats with this regexp + (($day,$mon,$yr,$hr,$min,$sec,$tz) = + /^ + (\d\d?) # day + (?:\s+|[-\/]) + (\w+) # month + (?:\s+|[-\/]) + (\d+) # year + (?: + (?:\s+|:) # separator before clock + (\d\d?):(\d\d) # hour:min + (?::(\d\d))? # optional seconds + )? # optional clock + \s* + ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone + \s* + (?:\(\w+\))? # ASCII representation of timezone in parens. + \s*$ + /x) + + || + + # Try the ctime and asctime format + (($mon, $day, $hr, $min, $sec, $tz, $yr) = + /^ + (\w{1,3}) # month + \s+ + (\d\d?) # day + \s+ + (\d\d?):(\d\d) # hour:min + (?::(\d\d))? # optional seconds + \s+ + (?:([A-Za-z]+)\s+)? # optional timezone + (\d+) # year + \s*$ # allow trailing whitespace + /x) + + || + + # Then the Unix 'ls -l' date format + (($mon, $day, $yr, $hr, $min, $sec) = + /^ + (\w{3}) # month + \s+ + (\d\d?) # day + \s+ + (?: + (\d\d\d\d) | # year + (\d{1,2}):(\d{2}) # hour:min + (?::(\d\d))? # optional seconds + ) + \s*$ + /x) + + || + + # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants + (($yr, $mon, $day, $hr, $min, $sec, $tz) = + /^ + (\d{4}) # year + [-\/]? + (\d\d?) # numerical month + [-\/]? + (\d\d?) # day + (?: + (?:\s+|[-:Tt]) # separator before clock + (\d\d?):?(\d\d) # hour:min + (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional) + )? # optional clock + \s* + ([-+]?\d\d?:?(:?\d\d)? + |Z|z)? # timezone (Z is "zero meridian", i.e. GMT) + \s*$ + /x) + + || + + # Windows 'dir' 11-12-96 03:52PM + (($mon, $day, $yr, $hr, $min, $ampm) = + /^ + (\d{2}) # numerical month + - + (\d{2}) # day + - + (\d{2}) # year + \s+ + (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM + \s*$ + /x) + + || + return; # unrecognized format + + # Translate month name to number + $mon = $MoY{$mon} || + $MoY{"\u\L$mon"} || + ($mon >= 1 && $mon <= 12 && int($mon)) || + return; + + # If the year is missing, we assume first date before the current, + # because of the formats we support such dates are mostly present + # on "ls -l" listings. + unless (defined $yr) { + my $cur_mon; + ($cur_mon, $yr) = (localtime)[4, 5]; + $yr += 1900; + $cur_mon++; + $yr-- if $mon > $cur_mon; + } + elsif (length($yr) < 3) { + # Find "obvious" year + my $cur_yr = (localtime)[5] + 1900; + my $m = $cur_yr % 100; + my $tmp = $yr; + $yr += $cur_yr - $m; + $m -= $tmp; + $yr += ($m > 0) ? 100 : -100 + if abs($m) > 50; + } + + # Make sure clock elements are defined + $hr = 0 unless defined($hr); + $min = 0 unless defined($min); + $sec = 0 unless defined($sec); + + # Compensate for AM/PM + if ($ampm) { + $ampm = uc $ampm; + $hr = 0 if $hr == 12 && $ampm eq 'AM'; + $hr += 12 if $ampm eq 'PM' && $hr != 12; + } + + return($yr, $mon, $day, $hr, $min, $sec, $tz) + if wantarray; + + if (defined $tz) { + $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/; + } else { + $tz = ""; + } + return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s", + $yr, $mon, $day, $hr, $min, $sec, $tz); +} + + +sub time2iso (;$) +{ + my $time = shift; + $time = time unless defined $time; + my($sec,$min,$hour,$mday,$mon,$year) = localtime($time); + sprintf("%04d-%02d-%02d %02d:%02d:%02d", + $year+1900, $mon+1, $mday, $hour, $min, $sec); +} + + +sub time2isoz (;$) +{ + my $time = shift; + $time = time unless defined $time; + my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time); + sprintf("%04d-%02d-%02d %02d:%02d:%02dZ", + $year+1900, $mon+1, $mday, $hour, $min, $sec); +} + +1; + + +__END__ + +=head1 NAME + +HTTP::Date - date conversion routines + +=head1 SYNOPSIS + + use HTTP::Date; + + $string = time2str($time); # Format as GMT ASCII time + $time = str2time($string); # convert ASCII date to machine time + +=head1 DESCRIPTION + +This module provides functions that deal the date formats used by the +HTTP protocol (and then some more). Only the first two functions, +time2str() and str2time(), are exported by default. + +=over 4 + +=item time2str( [$time] ) + +The time2str() function converts a machine time (seconds since epoch) +to a string. If the function is called without an argument, it will +use the current time. + +The string returned is in the format preferred for the HTTP protocol. +This is a fixed length subset of the format defined by RFC 1123, +represented in Universal Time (GMT). An example of a time stamp +in this format is: + + Sun, 06 Nov 1994 08:49:37 GMT + +=item str2time( $str [, $zone] ) + +The str2time() function converts a string to machine time. It returns +C if the format of $str is unrecognized, or the time is outside +the representable range. The time formats recognized are the same as +for parse_date(). + +The function also takes an optional second argument that specifies the +default time zone to use when converting the date. This parameter is +ignored if the zone is found in the date string itself. If this +parameter is missing, and the date string format does not contain any +zone specification, then the local time zone is assumed. + +If the zone is not "C" or numerical (like "C<-0800>" or +"C<+0100>"), then the C module must be installed in order +to get the date recognized. + +=item parse_date( $str ) + +This function will try to parse a date string, and then return it as a +list of numerical values followed by a (possible undefined) time zone +specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year +returned will B have the number 1900 subtracted from it and the +$month numbers start with 1. + +In scalar context the numbers are interpolated in a string of the +"YYYY-MM-DD hh:mm:ss TZ"-format and returned. + +If the date is unrecognized, then the empty list is returned. + +The function is able to parse the following formats: + + "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format + "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format + "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format + "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format + "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format + + "03/Feb/1994:17:03:55 -0700" -- common logfile format + "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday) + "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday) + "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday) + + "1994-02-03 14:15:29 -0100" -- ISO 8601 format + "1994-02-03 14:15:29" -- zone is optional + "1994-02-03" -- only date + "1994-02-03T14:15:29" -- Use T as separator + "19940203T141529Z" -- ISO 8601 compact format + "19940203" -- only date + + "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time) + "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time) + "09 Feb 1994" -- proposed new HTTP format (no weekday, no time) + "03/Feb/1994" -- common logfile format (no time, no offset) + + "Feb 3 1994" -- Unix 'ls -l' format + "Feb 3 17:03" -- Unix 'ls -l' format + + "11-15-96 03:52PM" -- Windows 'dir' format + +The parser ignores leading and trailing whitespace. It also allow the +seconds to be missing and the month to be numerical in most formats. + +If the year is missing, then we assume that the date is the first +matching date I current month. If the year is given with only +2 digits, then parse_date() will select the century that makes the +year closest to the current date. + +=item time2iso( [$time] ) + +Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted +string representing time in the local time zone. + +=item time2isoz( [$time] ) + +Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted +string representing Universal Time. + + +=back + +=head1 SEE ALSO + +L, L + +=head1 COPYRIGHT + +Copyright 1995-1999, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Request/Common.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Request/Common.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Request/Common.pm (revision 1098) @@ -0,0 +1,443 @@ +# $Id: Common.pm,v 1.19 2001/01/05 18:53:11 gisle Exp $ +# +package HTTP::Request::Common; + +use strict; +use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD); + +$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why) + +require Exporter; +*import = \&Exporter::import; +@EXPORT =qw(GET HEAD PUT POST); +@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD); + +require HTTP::Request; +use Carp(); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/); + +my $CRLF = "\015\012"; # "\r\n" is not portable + +sub GET { _simple_req('GET', @_); } +sub HEAD { _simple_req('HEAD', @_); } +sub PUT { _simple_req('PUT' , @_); } + +sub POST +{ + my $url = shift; + my $req = HTTP::Request->new(POST => $url); + my $content; + $content = shift if @_ and ref $_[0]; + my($k, $v); + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $content = $v; + } else { + $req->push_header($k, $v); + } + } + my $ct = $req->header('Content-Type'); + unless ($ct) { + $ct = 'application/x-www-form-urlencoded'; + } elsif ($ct eq 'form-data') { + $ct = 'multipart/form-data'; + } + + if (ref $content) { + if ($ct =~ m,^multipart/form-data\s*(;|$),i) { + require HTTP::Headers::Util; + my @v = HTTP::Headers::Util::split_header_words($ct); + Carp::carp("Multiple Content-Type headers") if @v > 1; + @v = @{$v[0]}; + + my $boundary; + my $boundary_index; + for (my @tmp = @v; @tmp;) { + my($k, $v) = splice(@tmp, 0, 2); + if (lc($k) eq "boundary") { + $boundary = $v; + $boundary_index = @v - @tmp - 1; + last; + } + } + + ($content, $boundary) = form_data($content, $boundary, $req); + + if ($boundary_index) { + $v[$boundary_index] = $boundary; + } else { + push(@v, boundary => $boundary); + } + + $ct = HTTP::Headers::Util::join_header_words(@v); + } else { + # We use a temporary URI object to format + # the application/x-www-form-urlencoded content. + require URI; + my $url = URI->new('http:'); + $url->query_form(ref($content) eq "HASH" ? %$content : @$content); + $content = $url->query; + } + } + + $req->header('Content-Type' => $ct); # might be redundant + if (defined($content)) { + $req->header('Content-Length' => + length($content)) unless ref($content); + $req->content($content); + } + $req; +} + + +sub _simple_req +{ + my($method, $url) = splice(@_, 0, 2); + my $req = HTTP::Request->new($method => $url); + my($k, $v); + while (($k,$v) = splice(@_, 0, 2)) { + if (lc($k) eq 'content') { + $req->add_content($v); + } else { + $req->push_header($k, $v); + } + } + $req; +} + + +sub form_data # RFC1867 +{ + my($data, $boundary, $req) = @_; + my @data = ref($data) eq "HASH" ? %$data : @$data; # copy + my $fhparts; + my @parts; + my($k,$v); + while (($k,$v) = splice(@data, 0, 2)) { + if (!ref($v)) { + $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes + push(@parts, + qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v)); + } else { + my($file, $usename, @headers) = @$v; + unless (defined $usename) { + $usename = $file; + $usename =~ s,.*/,, if defined($usename); + } + my $disp = qq(form-data; name="$k"); + $disp .= qq(; filename="$usename") if $usename; + my $content = ""; + my $h = HTTP::Headers->new(@headers); + my $ct = $h->header("Content-Type"); + if ($file) { + require Symbol; + my $fh = Symbol::gensym(); + open($fh, $file) or Carp::croak("Can't open file $file: $!"); + binmode($fh); + if ($DYNAMIC_FILE_UPLOAD) { + # will read file later + $content = $fh; + } else { + local($/) = undef; # slurp files + $content = <$fh>; + close($fh); + $h->header("Content-Length" => length($content)); + } + unless ($ct) { + require LWP::MediaTypes; + $ct = LWP::MediaTypes::guess_media_type($file, $h); + } + } + if ($h->header("Content-Disposition")) { + # just to get it sorted first + $disp = $h->header("Content-Disposition"); + $h->remove_header("Content-Disposition"); + } + if ($h->header("Content")) { + $content = $h->header("Content"); + $h->remove_header("Content"); + } + my $head = join($CRLF, "Content-Disposition: $disp", + $h->as_string($CRLF), + ""); + if (ref $content) { + push(@parts, [$head, $content]); + $fhparts++; + } else { + push(@parts, $head . $content); + } + } + } + return "" unless @parts; + + my $content; + if ($fhparts) { + $boundary = boundary(10) # hopefully enough randomness + unless $boundary; + + # add the boundaries to the @parts array + for (1..@parts-1) { + splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF"); + } + unshift(@parts, "--$boundary$CRLF"); + push(@parts, "$CRLF--$boundary--$CRLF"); + + # See if we can generate Content-Length header + my $length = 0; + for (@parts) { + if (ref $_) { + my ($head, $f) = @$_; + my $file_size; + unless ( -f $f && ($file_size = -s _) ) { + # The file is either a dynamic file like /dev/audio + # or perhaps a file in the /proc file system where + # stat may return a 0 size even though reading it + # will produce data. So we cannot make + # a Content-Length header. + undef $length; + last; + } + $length += $file_size + length $head; + } else { + $length += length; + } + } + $length && $req->header('Content-Length' => $length); + + # set up a closure that will return content piecemeal + $content = sub { + for (;;) { + unless (@parts) { + defined $length && $length != 0 && + Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer."; + return; + } + my $p = shift @parts; + unless (ref $p) { + $p .= shift @parts while @parts && !ref($parts[0]); + defined $length && ($length -= length $p); + return $p; + } + my($buf, $fh) = @$p; + my $buflength = length $buf; + my $n = read($fh, $buf, 2048, $buflength); + if ($n) { + $buflength += $n; + unshift(@parts, ["", $fh]); + } else { + close($fh); + } + if ($buflength) { + defined $length && ($length -= $buflength); + return $buf + } + } + }; + + } else { + $boundary = boundary() unless $boundary; + + my $bno = 0; + CHECK_BOUNDARY: + { + for (@parts) { + if (index($_, $boundary) >= 0) { + # must have a better boundary + $boundary = boundary(++$bno); + redo CHECK_BOUNDARY; + } + } + last; + } + $content = "--$boundary$CRLF" . + join("$CRLF--$boundary$CRLF", @parts) . + "$CRLF--$boundary--$CRLF"; + } + + wantarray ? ($content, $boundary) : $content; +} + + +sub boundary +{ + my $size = shift || return "xYzZY"; + require MIME::Base64; + my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), ""); + $b =~ s/[\W]/X/g; # ensure alnum only + $b; +} + +1; + +__END__ + +=head1 NAME + +HTTP::Request::Common - Construct common HTTP::Request objects + +=head1 SYNOPSIS + + use HTTP::Request::Common; + $ua = LWP::UserAgent->new; + $ua->request(GET 'http://www.sn.no/'); + $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]); + +=head1 DESCRIPTION + +This module provide functions that return newly created HTTP::Request +objects. These functions are usually more convenient to use than the +standard HTTP::Request constructor for these common requests. The +following functions are provided. + +=over 4 + +=item GET $url, Header => Value,... + +The GET() function returns a HTTP::Request object initialized with the +GET method and the specified URL. Without additional arguments it +is exactly equivalent to the following call + + HTTP::Request->new(GET => $url) + +but is less cluttered. It also reads better when used together with the +LWP::UserAgent->request() method: + + my $ua = new LWP::UserAgent; + my $res = $ua->request(GET 'http://www.sn.no') + if ($res->is_success) { ... + +You can also initialize header values in the request by specifying +some key/value pairs as optional arguments. For instance: + + $ua->request(GET 'http://www.sn.no', + If_Match => 'foo', + From => 'gisle@aas.no', + ); + +A header key called 'Content' is special and when seen the value will +initialize the content part of the request instead of setting a header. + +=item HEAD $url, [Header => Value,...] + +Like GET() but the method in the request is HEAD. + +=item PUT $url, [Header => Value,...] + +Like GET() but the method in the request is PUT. + +=item POST $url, [$form_ref], [Header => Value,...] + +This works mostly like GET() with POST as the method, but this function +also takes a second optional array or hash reference parameter +($form_ref). This argument can be used to pass key/value pairs for +the form content. By default we will initialize a request using the +C content type. This means that +you can emulate a HTML Eform> POSTing like this: + + POST 'http://www.perl.org/survey.cgi', + [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + perc => '3%', + ]; + +This will create a HTTP::Request object that looks like this: + + POST http://www.perl.org/survey.cgi + Content-Length: 66 + Content-Type: application/x-www-form-urlencoded + + name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25 + +The POST method also supports the C content used +for I as specified in RFC 1867. You trigger +this content format by specifying a content type of C<'form-data'> as +one of the request headers. If one of the values in the $form_ref is +an array reference, then it is treated as a file part specification +with the following interpretation: + + [ $file, $filename, Header => Value... ] + +The first value in the array ($file) is the name of a file to open. +This file will be read and its content placed in the request. The +routine will croak if the file can't be opened. Use an C as $file +value if you want to specify the content directly. The $filename is +the filename to report in the request. If this value is undefined, +then the basename of the $file will be used. You can specify an empty +string as $filename if you don't want any filename in the request. + +Sending my F<~/.profile> to the survey used as example above can be +achieved by this: + + POST 'http://www.perl.org/survey.cgi', + Content_Type => 'form-data', + Content => [ name => 'Gisle Aas', + email => 'gisle@aas.no', + gender => 'M', + born => '1964', + init => ["$ENV{HOME}/.profile"], + ] + +This will create a HTTP::Request object that almost looks this (the +boundary and the content of your F<~/.profile> is likely to be +different): + + POST http://www.perl.org/survey.cgi + Content-Length: 388 + Content-Type: multipart/form-data; boundary="6G+f" + + --6G+f + Content-Disposition: form-data; name="name" + + Gisle Aas + --6G+f + Content-Disposition: form-data; name="email" + + gisle@aas.no + --6G+f + Content-Disposition: form-data; name="gender" + + M + --6G+f + Content-Disposition: form-data; name="born" + + 1964 + --6G+f + Content-Disposition: form-data; name="init"; filename=".profile" + Content-Type: text/plain + + PATH=/local/perl/bin:$PATH + export PATH + + --6G+f-- + +If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE +value, then you get back a request object with a subroutine closure as +the content attribute. This subroutine will read the content of any +files on demand and return it in suitable chunks. This allow you to +upload arbitrary big files without using lots of memory. You can even +upload infinite files like F if you wish; however, if +the file is not a plain file, there will be no Content-Length header +defined for the request. Not all servers (or server +applications) like this. Also, if the file(s) change in size between +the time the Content-Length is calculated and the time that the last +chunk is delivered, the subroutine will C. + +=back + +=head1 SEE ALSO + +L, L + + +=head1 COPYRIGHT + +Copyright 1997-2000, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + Index: /branches/mt4.11/extlib/HTTP/Response.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Response.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Response.pm (revision 1098) @@ -0,0 +1,394 @@ +# +# $Id: Response.pm,v 1.36 2001/11/15 06:42:40 gisle Exp $ + +package HTTP::Response; + + +=head1 NAME + +HTTP::Response - Class encapsulating HTTP Responses + +=head1 SYNOPSIS + + require HTTP::Response; + +=head1 DESCRIPTION + +The C class encapsulates HTTP style responses. A +response consists of a response line, some headers, and (potentially +empty) content. Note that the LWP library also uses HTTP style +responses for non-HTTP protocol schemes. + +Instances of this class are usually created and returned by the +C method of an C object: + + #... + $response = $ua->request($request) + if ($response->is_success) { + print $response->content; + } else { + print $response->error_as_HTML; + } + +C is a subclass of C and therefore +inherits its methods. The inherited methods most often used are header(), +push_header(), remove_header(), and content(). +The header convenience methods are also available. See +L for details. + +The following additional methods are available: + +=over 4 + +=cut + + +require HTTP::Message; +@ISA = qw(HTTP::Message); +$VERSION = sprintf("%d.%02d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/); + +use HTTP::Status (); +use strict; + + +=item $r = HTTP::Response->new($rc, [$msg, [$header, [$content]]]) + +Constructs a new C object describing a response with +response code C<$rc> and optional message C<$msg>. The message is a +short human readable single line string that explains the response +code. + +=cut + +sub new +{ + my($class, $rc, $msg, $header, $content) = @_; + my $self = $class->SUPER::new($header, $content); + $self->code($rc); + $self->message($msg); + $self; +} + + +sub clone +{ + my $self = shift; + my $clone = bless $self->SUPER::clone, ref($self); + $clone->code($self->code); + $clone->message($self->message); + $clone->request($self->request->clone) if $self->request; + # we don't clone previous + $clone; +} + +=item $r->code([$code]) + +=item $r->message([$message]) + +=item $r->request([$request]) + +=item $r->previous([$previousResponse]) + +These methods provide public access to the object attributes. The +first two contain respectively the response code and the message +of the response. + +The request attribute is a reference the request that caused this +response. It does not have to be the same request as passed to the +$ua->request() method, because there might have been redirects and +authorization retries in between. + +The previous attribute is used to link together chains of responses. +You get chains of responses if the first response is redirect or +unauthorized. + +=cut + +sub code { shift->_elem('_rc', @_); } +sub message { shift->_elem('_msg', @_); } +sub previous { shift->_elem('_previous',@_); } +sub request { shift->_elem('_request', @_); } + +=item $r->status_line + +Returns the string "Ecode> Emessage>". If the message attribute +is not set then the official name of Ecode> (see L) +is substituted. + +=cut + +sub status_line +{ + my $self = shift; + my $code = $self->{'_rc'} || "000"; + my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "?"; + return "$code $mess"; +} + +=item $r->base + +Returns the base URI for this response. The return value will be a +reference to a URI object. + +The base URI is obtained from one the following sources (in priority +order): + +=over 4 + +=item 1. + +Embedded in the document content, for instance +in HTML documents. + +=item 2. + +A "Content-Base:" or a "Content-Location:" header in the response. + +For backwards compatability with older HTTP implementations we will +also look for the "Base:" header. + +=item 3. + +The URI used to request this response. This might not be the original +URI that was passed to $ua->request() method, because we might have +received some redirect responses first. + +=back + +When the LWP protocol modules produce the HTTP::Response object, then +any base URI embedded in the document (step 1) will already have +initialized the "Content-Base:" header. This means that this method +only performs the last 2 steps (the content is not always available +either). + +=cut + +sub base +{ + my $self = shift; + my $base = $self->header('Content-Base') || # used to be HTTP/1.1 + $self->header('Content-Location') || # HTTP/1.1 + $self->header('Base'); # HTTP/1.0 + return $HTTP::URI_CLASS->new_abs($base, $self->request->uri); + # So yes, if $base is undef, the return value is effectively + # just a copy of $self->request->uri. +} + + +=item $r->as_string + +Returns a textual representation of the response. Mainly +useful for debugging purposes. It takes no arguments. + +=cut + +sub as_string +{ + require HTTP::Status; + my $self = shift; + my @result; + #push(@result, "---- $self ----"); + my $code = $self->code; + my $status_message = HTTP::Status::status_message($code) || "Unknown code"; + my $message = $self->message || ""; + + my $status_line = "$code"; + my $proto = $self->protocol; + $status_line = "$proto $status_line" if $proto; + $status_line .= " ($status_message)" if $status_message ne $message; + $status_line .= " $message"; + push(@result, $status_line); + push(@result, $self->headers_as_string); + my $content = $self->content; + if (defined $content) { + push(@result, $content); + } + #push(@result, ("-" x 40)); + join("\n", @result, ""); +} + +=item $r->is_info + +=item $r->is_success + +=item $r->is_redirect + +=item $r->is_error + +These methods indicate if the response was informational, sucessful, a +redirection, or an error. + +=cut + +sub is_info { HTTP::Status::is_info (shift->{'_rc'}); } +sub is_success { HTTP::Status::is_success (shift->{'_rc'}); } +sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); } +sub is_error { HTTP::Status::is_error (shift->{'_rc'}); } + + +=item $r->error_as_HTML() + +Returns a string containing a complete HTML document indicating what +error occurred. This method should only be called when $r->is_error +is TRUE. + +=cut + +sub error_as_HTML +{ + my $self = shift; + my $title = 'An Error Occurred'; + my $body = $self->status_line; + return < +$title + +

$title

+$body + + +EOM +} + + +=item $r->current_age + +Calculates the "current age" of the response as +specified by Edraft-ietf-http-v11-spec-07> section 13.2.3. The +age of a response is the time since it was sent by the origin server. +The returned value is a number representing the age in seconds. + +=cut + +sub current_age +{ + my $self = shift; + # Implementation of section 13.2.3 + # (age calculations) + my $response_time = $self->client_date; + my $date = $self->date; + + my $age = 0; + if ($response_time && $date) { + $age = $response_time - $date; # apparent_age + $age = 0 if $age < 0; + } + + my $age_v = $self->header('Age'); + if ($age_v && $age_v > $age) { + $age = $age_v; # corrected_received_age + } + + my $request = $self->request; + if ($request) { + my $request_time = $request->date; + if ($request_time) { + # Add response_delay to age to get 'corrected_initial_age' + $age += $response_time - $request_time; + } + } + if ($response_time) { + $age += time - $response_time; + } + return $age; +} + + +=item $r->freshness_lifetime + +Calculates the "freshness lifetime" of the response +as specified by Edraft-ietf-http-v11-spec-07> section 13.2.4. The +"freshness lifetime" is the length of time between the generation of a +response and its expiration time. The returned value is a number +representing the freshness lifetime in seconds. + +If the response does not contain an "Expires" or a "Cache-Control" +header, then this function will apply some simple heuristic based on +'Last-Modified' to determine a suitable lifetime. + +=cut + +sub freshness_lifetime +{ + my $self = shift; + + # First look for the Cache-Control: max-age=n header + my @cc = $self->header('Cache-Control'); + if (@cc) { + my $cc; + for $cc (@cc) { + my $cc_dir; + for $cc_dir (split(/\s*,\s*/, $cc)) { + if ($cc_dir =~ /max-age\s*=\s*(\d+)/i) { + return $1; + } + } + } + } + + # Next possibility is to look at the "Expires" header + my $date = $self->date || $self->client_date || time; + my $expires = $self->expires; + unless ($expires) { + # Must apply heuristic expiration + my $last_modified = $self->last_modified; + if ($last_modified) { + my $h_exp = ($date - $last_modified) * 0.10; # 10% since last-mod + if ($h_exp < 60) { + return 60; # minimum + } elsif ($h_exp > 24 * 3600) { + # Should give a warning if more than 24 hours according to + # section 13.2.4, but I don't + # know how to do it from this function interface, so I just + # make this the maximum value. + return 24 * 3600; + } + return $h_exp; + } else { + return 3600; # 1 hour is fallback when all else fails + } + } + return $expires - $date; +} + + +=item $r->is_fresh + +Returns TRUE if the response is fresh, based on the values of +freshness_lifetime() and current_age(). If the response is no longer +fresh, then it has to be refetched or revalidated by the origin +server. + +=cut + +sub is_fresh +{ + my $self = shift; + $self->freshness_lifetime > $self->current_age; +} + + +=item $r->fresh_until + +Returns the time when this entiy is no longer fresh. + +=cut + +sub fresh_until +{ + my $self = shift; + return $self->freshness_lifetime - $self->current_age + time; +} + +1; + +=back + +=head1 COPYRIGHT + +Copyright 1995-2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Negotiate.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Negotiate.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Negotiate.pm (revision 1098) @@ -0,0 +1,526 @@ +# $Id: Negotiate.pm,v 1.11 2001/11/27 22:41:33 gisle Exp $ +# + +package HTTP::Negotiate; + +$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/); +sub Version { $VERSION; } + +require 5.002; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(choose); + +require HTTP::Headers; + +$DEBUG = 0; + +sub choose ($;$) +{ + my($variants, $request) = @_; + my(%accept); + + unless (defined $request) { + # Create a request object from the CGI envirionment variables + $request = new HTTP::Headers; + $request->header('Accept', $ENV{HTTP_ACCEPT}) + if $ENV{HTTP_ACCEPT}; + $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET}) + if $ENV{HTTP_ACCEPT_CHARSET}; + $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING}) + if $ENV{HTTP_ACCEPT_ENCODING}; + $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE}) + if $ENV{HTTP_ACCEPT_LANGUAGE}; + } + + # Get all Accept values from the request. Build a hash initialized + # like this: + # + # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 }, + # 'audio/basic' => { q => 1 }, + # }, + # language => { 'no' => { q => 1 }, + # } + # ); + + $request->scan(sub { + my($key, $val) = @_; + + my $type; + if ($key =~ s/^Accept-//) { + $type = lc($key); + } + elsif ($key eq "Accept") { + $type = "type"; + } + else { + return; + } + + $val =~ s/\s+//g; + my $default_q = 1; + for my $name (split(/,/, $val)) { + my(%param, $param); + if ($name =~ s/;(.*)//) { + for $param (split(/;/, $1)) { + my ($pk, $pv) = split(/=/, $param, 2); + $param{lc $pk} = $pv; + } + } + $name = lc $name; + if (defined $param{'q'}) { + $param{'q'} = 1 if $param{'q'} > 1; + $param{'q'} = 0 if $param{'q'} < 0; + } else { + $param{'q'} = $default_q; + + # This makes sure that the first ones are slightly better off + # and therefore more likely to be chosen. + $default_q -= 0.0001; + } + $accept{$type}{$name} = \%param; + } + }); + + # Check if any of the variants specify a language. We do this + # because it influences how we treat those without (they default to + # 0.5 instead of 1). + my $any_lang = 0; + for $var (@$variants) { + if ($var->[5]) { + $any_lang = 1; + last; + } + } + + if ($DEBUG) { + print "Negotiation parameters in the request\n"; + for $type (keys %accept) { + print " $type:\n"; + for $name (keys %{$accept{$type}}) { + print " $name\n"; + for $pv (keys %{$accept{$type}{$name}}) { + print " $pv = $accept{$type}{$name}{$pv}\n"; + } + } + } + } + + my @Q = (); # This is where we collect the results of the + # quality calcualtions + + # Calculate quality for all the variants that are available. + for (@$variants) { + my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_; + $qs = 1 unless defined $qs; + $ct = '' unless defined $ct; + $bs = 0 unless defined $bs; + $lang = lc($lang) if $lang; # lg tags are always case-insensitive + if ($DEBUG) { + print "\nEvaluating $id (ct='$ct')\n"; + printf " qs = %.3f\n", $qs; + print " enc = $enc\n" if $enc && !ref($enc); + print " enc = @$enc\n" if $enc && ref($enc); + print " cs = $cs\n" if $cs; + print " lang = $lang\n" if $lang; + print " bs = $bs\n" if $bs; + } + + # Calculate encoding quality + my $qe = 1; + # If the variant has no assignes Content-Encoding, or if no + # Accept-Encoding field is present, then the value assigned + # is "qe=1". If *all* of the variant's content encoddings + # are listed in the Accept-Encoding field, then the value + # assigned is "qw=1". If *any* of the variant's content + # encodings are not listed in the provided Accept-Encoding + # field, then the value assigned is "qe=0" + if (exists $accept{'encoding'} && $enc) { + my @enc = ref($enc) ? @$enc : ($enc); + for (@enc) { + print "Is encoding $_ accepted? " if $DEBUG; + unless(exists $accept{'encoding'}{$_}) { + print "no\n" if $DEBUG; + $qe = 0; + last; + } else { + print "yes\n" if $DEBUG; + } + } + } + + # Calculate charset quality + my $qc = 1; + # If the variant's media-type has not charset parameter, + # or the variant's charset is US-ASCII, or if no Accept-Charset + # field is present, then the value assigned is "qc=1". If the + # variant's charset is listed in the Accept-Charset field, + # then the value assigned is "qc=1. Otherwise, if the variant's + # charset is not listed in the provided Accept-Encoding field, + # then the value assigned is "qc=0". + if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) { + $qc = 0 unless $accept{'charset'}{$cs}; + } + + # Calculate language quality + my $ql = 1; + if ($lang && exists $accept{'language'}) { + my @lang = ref($lang) ? @$lang : ($lang); + # If any of the variant's content languages are listed + # in the Accept-Language field, the the value assigned is + # the maximus of the "q" paramet values for thos language + # tags. + my $q = undef; + for (@lang) { + next unless exists $accept{'language'}{$_}; + my $this_q = $accept{'language'}{$_}{'q'}; + $q = $this_q unless defined $q; + $q = $this_q if $this_q > $q; + } + if(defined $q) { + $DEBUG and print " -- Exact language match at q=$q\n"; + } else { + # If there was no exact match and at least one of + # the Accept-Language field values is a complete + # subtag prefix of the content language tag(s), then + # the "q" parameter value of the largest matching + # prefix is used. + $DEBUG and print " -- No exact language match\n"; + my $selected = undef; + for $al (keys %{ $accept{'language'} }) { + if (substr($lang, 0, 1 + length($al)) eq "$al-") { + # $lang starting with $al isn't enough, or else + # Accept-Language: hu (Hungarian) would seem + # to accept a document in hup (Hupa) + $DEBUG and print " -- $lang ISA $al\n"; + $selected = $al unless defined $selected; + $selected = $al if length($al) > length($selected); + } else { + $DEBUG and print " -- $lang isn't a $al\n"; + } + } + $q = $accept{'language'}{$selected}{'q'} if $selected; + + # If none of the variant's content language tags or + # tag prefixes are listed in the provided + # Accept-Language field, then the value assigned + # is "ql=0.001" + $q = 0.001 unless defined $q; + } + $ql = $q; + } else { + $ql = 0.5 if $any_lang && exists $accept{'language'}; + } + + my $q = 1; + my $mbx = undef; + # If no Accept field is given, then the value assigned is "q=1". + # If at least one listed media range matches the variant's media + # type, then the "q" parameter value assigned to the most specific + # of those matched is used (e.g. "text/html;version=3.0" is more + # specific than "text/html", which is more specific than "text/*", + # which in turn is more specific than "*/*"). If not media range + # in the provided Accept field matches the variant's media type, + # then the value assigned is "q=0". + if (exists $accept{'type'} && $ct) { + # First we clean up our content-type + $ct =~ s/\s+//g; + my $params = ""; + $params = $1 if $ct =~ s/;(.*)//; + my($type, $subtype) = split("/", $ct, 2); + my %param = (); + for $param (split(/;/, $params)) { + my($pk,$pv) = split(/=/, $param, 2); + $param{$pk} = $pv; + } + + my $sel_q = undef; + my $sel_mbx = undef; + my $sel_specificness = 0; + + ACCEPT_TYPE: + for $at (keys %{ $accept{'type'} }) { + print "Consider $at...\n" if $DEBUG; + my($at_type, $at_subtype) = split("/", $at, 2); + # Is it a match on the type + next if $at_type ne '*' && $at_type ne $type; + next if $at_subtype ne '*' && $at_subtype ne $subtype; + my $specificness = 0; + $specificness++ if $at_type ne '*'; + $specificness++ if $at_subtype ne '*'; + # Let's see if content-type parameters also match + while (($pk, $pv) = each %param) { + print "Check if $pk = $pv is true\n" if $DEBUG; + next unless exists $accept{'type'}{$at}{$pk}; + next ACCEPT_TYPE + unless $accept{'type'}{$at}{$pk} eq $pv; + print "yes it is!!\n" if $DEBUG; + $specificness++; + } + print "Hurray, type match with specificness = $specificness\n" + if $DEBUG; + + if (!defined($sel_q) || $sel_specificness < $specificness) { + $sel_q = $accept{'type'}{$at}{'q'}; + $sel_mbx = $accept{'type'}{$at}{'mbx'}; + $sel_specificness = $specificness; + } + } + $q = $sel_q || 0; + $mbx = $sel_mbx; + } + + my $Q; + if (!defined($mbx) || $mbx >= $bs) { + $Q = $qs * $qe * $qc * $ql * $q; + } else { + $Q = 0; + print "Variant's size is too large ==> Q=0\n" if $DEBUG; + } + + if ($DEBUG) { + $mbx = "undef" unless defined $mbx; + printf "Q=%.4f", $Q; + print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n"; + } + + push(@Q, [$id, $Q, $bs]); + } + + + @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q; + + return @Q if wantarray; + return undef unless @Q; + return undef if $Q[0][1] == 0; + $Q[0][0]; +} + +1; + +__END__ + + +=head1 NAME + +choose - choose a variant of a document to serve (HTTP content negotiation) + +=head1 SYNOPSIS + + use HTTP::Negotiate; + + # ID QS Content-Type Encoding Char-Set Lang Size + $variants = + [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000], + ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400], + ['var3', 0.3, 'image/gif', undef, undef, undef, 43555], + ]; + + @prefered = choose($variants, $request_headers); + $the_one = choose($variants); + +=head1 DESCRIPTION + +This module provides a complete implementation of the HTTP content +negotiation algorithm specified in F +chapter 12. Content negotiation allows for the selection of a +preferred content representation based upon attributes of the +negotiable variants and the value of the various Accept* header fields +in the request. + +The variants are ordered by preference by calling the function +choose(). + +The first parameter is reference to an array of the variants to +choose among. +Each element in this array is an array with the values [$id, $qs, +$content_type, $content_encoding, $charset, $content_language, +$content_length] whose meanings are described +below. The $content_encoding and $content_language can be either a +single scalar value or an array reference if there are several values. + +The second optional parameter is either a HTTP::Headers or a HTTP::Request +object which is searched for "Accept*" headers. If this +parameter is missing, then the accept specification is initialized +from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET, +HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE. + +In an array context, choose() returns a list of variant +identifier/calculated quality pairs. The values are sorted by +quality, highest quality first. If the calculated quality is the same +for two variants, then they are sorted by size (smallest first). I: + + (['var1' => 1], ['var2', 0.3], ['var3' => 0]); + +Note that also zero quality variants are included in the return list +even if these should never be served to the client. + +In a scalar context, it returns the identifier of the variant with the +highest score or C if none have non-zero quality. + +If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of +noise is generated on STDOUT during evaluation of choose(). + +=head1 VARIANTS + +A variant is described by a list of the following values. If the +attribute does not make sense or is unknown for a variant, then use +C instead. + +=over 3 + +=item identifier + +This is a string that you use as the name for the variant. This +identifier for the preferred variants returned by choose(). + +=item qs + +This is a number between 0.000 and 1.000 that describes the "source +quality". This is what F says about this +value: + +Source quality is measured by the content provider as representing the +amount of degradation from the original source. For example, a +picture in JPEG form would have a lower qs when translated to the XBM +format, and much lower qs when translated to an ASCII-art +representation. Note, however, that this is a function of the source +- an original piece of ASCII-art may degrade in quality if it is +captured in JPEG form. The qs values should be assigned to each +variant by the content provider; if no qs value has been assigned, the +default is generally "qs=1". + +=item content-type + +This is the media type of the variant. The media type does not +include a charset attribute, but might contain other parameters. +Examples are: + + text/html + text/html;version=2.0 + text/plain + image/gif + image/jpg + +=item content-encoding + +This is one or more content encodings that has been applied to the +variant. The content encoding is generally used as a modifier to the +content media type. The most common content encodings are: + + gzip + compress + +=item content-charset + +This is the character set used when the variant contains text. +The charset value should generally be C or one of these: + + us-ascii + iso-8859-1 ... iso-8859-9 + iso-2022-jp + iso-2022-jp-2 + iso-2022-kr + unicode-1-1 + unicode-1-1-utf-7 + unicode-1-1-utf-8 + +=item content-language + +This describes one or more languages that are used in the variant. +Language is described like this in F: A +language is in this context a natural language spoken, written, or +otherwise conveyed by human beings for communication of information to +other human beings. Computer languages are explicitly excluded. + +The language tags are defined by RFC 3066. Examples +are: + + no Norwegian + en International English + en-US US English + en-cockney + +=item content-length + +This is the number of bytes used to represent the content. + +=back + +=head1 ACCEPT HEADERS + +The following Accept* headers can be used for describing content +preferences in a request (This description is an edited extract from +F): + +=over 3 + +=item Accept + +This header can be used to indicate a list of media ranges which are +acceptable as a reponse to the request. The "*" character is used to +group media types into ranges, with "*/*" indicating all media types +and "type/*" indicating all subtypes of that type. + +The parameter q is used to indicate the quality factor, which +represents the user's preference for that range of media types. The +parameter mbx gives the maximum acceptable size of the response +content. The default values are: q=1 and mbx=infinity. If no Accept +header is present, then the client accepts all media types with q=1. + +For example: + + Accept: audio/*;q=0.2;mbx=200000, audio/basic + +would mean: "I prefer audio/basic (of any size), but send me any audio +type if it is the best available after an 80% mark-down in quality and +its size is less than 200000 bytes" + + +=item Accept-Charset + +Used to indicate what character sets are acceptable for the response. +The "us-ascii" character set is assumed to be acceptable for all user +agents. If no Accept-Charset field is given, the default is that any +charset is acceptable. Example: + + Accept-Charset: iso-8859-1, unicode-1-1 + + +=item Accept-Encoding + +Restricts the Content-Encoding values which are acceptable in the +response. If no Accept-Encoding field is present, the server may +assume that the client will accept any content encoding. An empty +Accept-Encoding means that no content encoding is acceptable. Example: + + Accept-Encoding: compress, gzip + + +=item Accept-Language + +This field is similar to Accept, but restricts the set of natural +languages that are preferred in a response. Each language may be +given an associated quality value which represents an estimate of the +user's comprehension of that language. For example: + + Accept-Language: no, en-gb;q=0.8, de;q=0.55 + +would mean: "I prefer Norwegian, but will accept British English (with +80% comprehension) or German (with 55% comprehension). + +=back + + +=head1 COPYRIGHT + +Copyright 1996,2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AUTHOR + +Gisle Aas + +=cut Index: /branches/mt4.11/extlib/HTTP/Headers/Util.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Headers/Util.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Headers/Util.pm (revision 1098) @@ -0,0 +1,180 @@ +package HTTP::Headers::Util; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/); + +require Exporter; +@ISA=qw(Exporter); + +@EXPORT_OK=qw(split_header_words join_header_words); + +=head1 NAME + +HTTP::Headers::Util - Header value parsing utility functions + +=head1 SYNOPSIS + + use HTTP::Headers::Util qw(split_header_words); + @values = split_header_words($h->header("Content-Type")); + +=head1 DESCRIPTION + +This module provides a few functions that helps parsing and +construction of valid HTTP header values. None of the functions are +exported by default. + +The following functions are available: + +=over 4 + + +=item split_header_words( @header_values ) + +This function will parse the header values given as argument into a +list of anonymous arrays containing key/value pairs. The function +knows how to deal with ",", ";" and "=" as well as quoted values after +"=". A list of space separated tokens are parsed as if they were +separated by ";". + +If the @header_values passed as argument contains multiple values, +then they are treated as if they were a single value separated by +comma ",". + +This means that this function is useful for parsing header fields that +follow this syntax (BNF as from the HTTP/1.1 specification, but we relax +the requirement for tokens). + + headers = #header + header = (token | parameter) *( [";"] (token | parameter)) + + token = 1* + separators = "(" | ")" | "<" | ">" | "@" + | "," | ";" | ":" | "\" | <"> + | "/" | "[" | "]" | "?" | "=" + | "{" | "}" | SP | HT + + quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) + qdtext = > + quoted-pair = "\" CHAR + + parameter = attribute "=" value + attribute = token + value = token | quoted-string + +Each I
is represented by an anonymous array of key/value +pairs. The value for a simple token (not part of a parameter) is C. +Syntactically incorrect headers will not necessary be parsed as you +would want. + +This is easier to describe with some examples: + + split_header_words('foo="bar"; port="80,81"; discard, bar=baz') + split_header_words('text/html; charset="iso-8859-1"); + split_header_words('Basic realm="\"foo\\bar\""'); + +will return + + [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ] + ['text/html' => undef, charset => 'iso-8859-1'] + [Basic => undef, realm => '"foo\bar"'] + +=cut + + +sub split_header_words +{ + my(@val) = @_; + my @res; + for (@val) { + my @cur; + while (length) { + if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' + push(@cur, $1); + # a quoted value + if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { + my $val = $1; + $val =~ s/\\(.)/$1/g; + push(@cur, $val); + # some unquoted value + } elsif (s/^\s*=\s*([^;,\s]*)//) { + my $val = $1; + $val =~ s/\s+$//; + push(@cur, $val); + # no value, a lone token + } else { + push(@cur, undef); + } + } elsif (s/^\s*,//) { + push(@res, [@cur]) if @cur; + @cur = (); + } elsif (s/^\s*;// || s/^\s+//) { + # continue + } else { + die "This should not happen: '$_'"; + } + } + push(@res, \@cur) if @cur; + } + @res; +} + + +=item join_header_words( @arrays ) + +This will do the opposite of the conversion done by split_header_words(). +It takes a list of anonymous arrays as arguments (or a list of +key/value pairs) and produces a single header value. Attribute values +are quoted if needed. + +Example: + + join_header_words(["text/plain" => undef, charset => "iso-8859/1"]); + join_header_words("text/plain" => undef, charset => "iso-8859/1"); + +will both return the string: + + text/plain; charset="iso-8859/1" + +=cut + +sub join_header_words +{ + @_ = ([@_]) if @_ && !ref($_[0]); + my @res; + for (@_) { + my @cur = @$_; + my @attr; + while (@cur) { + my $k = shift @cur; + my $v = shift @cur; + if (defined $v) { + if ($v =~ /^\w+$/) { + $k .= "=$v"; + } else { + $v =~ s/([\"\\])/\\$1/g; # escape " and \ + $k .= qq(="$v"); + } + } + push(@attr, $k); + } + push(@res, join("; ", @attr)) if @attr; + } + join(", ", @res); +} + +1; + +__END__ + +=back + +=head1 COPYRIGHT + +Copyright 1997-1998, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/HTTP/Headers/ETag.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Headers/ETag.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Headers/ETag.pm (revision 1098) @@ -0,0 +1,88 @@ +package HTTP::Headers::ETag; + +use strict; +use vars qw($VERSION); +$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/); + +require HTTP::Date; + +require HTTP::Headers; +package HTTP::Headers; + +sub _etags +{ + my $self = shift; + my $header = shift; + my @old = _split_etag_list($self->_header($header)); + if (@_) { + $self->_header($header => join(", ", _split_etag_list(@_))); + } + wantarray ? @old : join(", ", @old); +} + +sub etag { shift->_etags("ETag", @_); } +sub if_match { shift->_etags("If-Match", @_); } +sub if_none_match { shift->_etags("If-None-Match", @_); } + +sub if_range { + # Either a date or an entity-tag + my $self = shift; + my @old = $self->_header("If-Range"); + if (@_) { + my $new = shift; + if (!defined $new) { + $self->remove_header("If-Range"); + } elsif ($new =~ /^\d+$/) { + $self->_date_header("If-Range", $new); + } else { + $self->_etags("If-Range", $new); + } + } + return unless defined(wantarray); + for (@old) { + my $t = HTTP::Date::str2time($_); + $_ = $t if $t; + } + wantarray ? @old : join(", ", @old); +} + + +# Split a list of entity tag values. The return value is a list +# consisting of one element per entity tag. Suitable for parsing +# headers like C, C. You might even want to +# use it on C and C entity tag values, because it will +# normalize them to the common form. +# +# entity-tag = [ weak ] opaque-tag +# weak = "W/" +# opaque-tag = quoted-string + + +sub _split_etag_list +{ + my(@val) = @_; + my @res; + for (@val) { + while (length) { + my $weak = ""; + $weak = "W/" if s,^\s*[wW]/,,; + my $etag = ""; + if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) { + push(@res, "$weak$1"); + } elsif (s/^\s*,//) { + push(@res, qq(W/"")) if $weak; + } elsif (s/^\s*([^,\s]+)//) { + $etag = $1; + $etag =~ s/([\"\\])/\\$1/g; + push(@res, qq($weak"$etag")); + } elsif (s/^\s+// || !length) { + push(@res, qq(W/"")) if $weak; + } else { + die "This should not happen: '$_'"; + } + } + } + @res; +} + +1; Index: /branches/mt4.11/extlib/HTTP/Headers/Auth.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Headers/Auth.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Headers/Auth.pm (revision 1098) @@ -0,0 +1,94 @@ +package HTTP::Headers::Auth; + +use strict; +use vars qw($VERSION); +$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); + +require HTTP::Headers; +package HTTP::Headers; + +BEGIN { + # we provide a new (and better) implementations below + undef(&www_authenticate); + undef(&proxy_authenticate); +} + +require HTTP::Headers::Util; + +sub _parse_authenticate +{ + my @ret; + for (HTTP::Headers::Util::split_header_words(@_)) { + if (!defined($_->[1])) { + # this is a new auth scheme + push(@ret, lc(shift @$_) => {}); + shift @$_; + } + if (@ret) { + # this a new parameter pair for the last auth scheme + while (@$_) { + my $k = lc(shift @$_); + my $v = shift @$_; + $ret[-1]{$k} = $v; + } + } else { + # something wrong, parameter pair without any scheme seen + # IGNORE + } + } + @ret; +} + +sub _authenticate +{ + my $self = shift; + my $header = shift; + my @old = $self->_header($header); + if (@_) { + $self->remove_header($header); + my @new = @_; + while (@new) { + my $a_scheme = shift(@new); + if ($a_scheme =~ /\s/) { + # assume complete valid value, pass it through + $self->push_header($header, $a_scheme); + } else { + my @param; + if (@new) { + my $p = $new[0]; + if (ref($p) eq "ARRAY") { + @param = @$p; + shift(@new); + } elsif (ref($p) eq "HASH") { + @param = %$p; + shift(@new); + } + } + my $val = ucfirst(lc($a_scheme)); + if (@param) { + my $sep = " "; + while (@param) { + my $k = shift @param; + my $v = shift @param; + if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") { + # must quote the value + $v =~ s,([\\\"]),\\$1,g; + $v = qq("$v"); + } + $val .= "$sep$k=$v"; + $sep = ", "; + } + } + $self->push_header($header, $val); + } + } + } + return unless defined wantarray; + wantarray ? _parse_authenticate(@old) : join(", ", @old); +} + + +sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) } +sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) } + +1; Index: /branches/mt4.11/extlib/HTTP/Daemon.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Daemon.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Daemon.pm (revision 1098) @@ -0,0 +1,821 @@ +# $Id: Daemon.pm,v 1.25 2001/08/07 19:32:40 gisle Exp $ +# + +use strict; + +package HTTP::Daemon; + +=head1 NAME + +HTTP::Daemon - a simple http server class + +=head1 SYNOPSIS + + use HTTP::Daemon; + use HTTP::Status; + + my $d = HTTP::Daemon->new || die; + print "Please contact me at: url, ">\n"; + while (my $c = $d->accept) { + while (my $r = $c->get_request) { + if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") { + # remember, this is *not* recommened practice :-) + $c->send_file_response("/etc/passwd"); + } else { + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + } + +=head1 DESCRIPTION + +Instances of the I class are HTTP/1.1 servers that +listen on a socket for incoming requests. The I is a +sub-class of I, so you can perform socket operations +directly on it too. + +The accept() method will return when a connection from a client is +available. In a scalar context the returned value will be a reference +to a object of the I class which is another +I subclass. In a list context a two-element array +is returned containing the new I reference +and the peer address; the list will be empty upon failure. Calling +the get_request() method on the I object +will read data from the client and return an I object +reference. + +This HTTP daemon does not fork(2) for you. Your application, i.e. the +user of the I is reponsible for forking if that is +desirable. Also note that the user is responsible for generating +responses that conform to the HTTP/1.1 protocol. The +I class provides some methods that make this easier. + +=head1 METHODS + +The following is a list of methods that are new (or enhanced) relative +to the I base class. + +=over 4 + +=cut + + +use vars qw($VERSION @ISA $PROTO $DEBUG); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/); + +use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa); +@ISA=qw(IO::Socket::INET); + +$PROTO = "HTTP/1.1"; + +=item $d = new HTTP::Daemon + +The constructor takes the same parameters as the +I constructor. It can also be called without specifying +any parameters. The daemon will then set up a listen queue of 5 +connections and allocate some random port number. A server that wants +to bind to some specific address on the standard HTTP port will be +constructed like this: + + $d = new HTTP::Daemon + LocalAddr => 'www.someplace.com', + LocalPort => 80; + +=cut + +sub new +{ + my($class, %args) = @_; + $args{Listen} ||= 5; + $args{Proto} ||= 'tcp'; + return $class->SUPER::new(%args); +} + + +=item $c = $d->accept([$pkg]) + +This method is the same as I but returns an +I reference by default. It returns undef if +you specify a timeout and no connection is made within that time. In +a scalar context the returned value will be a reference to a object of +the I class which is another +I subclass. In a list context a two-element array +is returned containing the new I reference +and the peer address; the list will be empty upon failure. + + +=cut + +sub accept +{ + my $self = shift; + my $pkg = shift || "HTTP::Daemon::ClientConn"; + my ($sock, $peer) = $self->SUPER::accept($pkg); + if ($sock) { + ${*$sock}{'httpd_daemon'} = $self; + return wantarray ? ($sock, $peer) : $sock; + } else { + return; + } +} + + +=item $d->url + +Returns a URL string that can be used to access the server root. + +=cut + +sub url +{ + my $self = shift; + my $url = "http://"; + my $addr = $self->sockaddr; + if ($addr eq INADDR_ANY) { + require Sys::Hostname; + $url .= lc Sys::Hostname::hostname(); + } + else { + $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr); + } + my $port = $self->sockport; + $url .= ":$port" if $port != 80; + $url .= "/"; + $url; +} + + +=item $d->product_tokens + +Returns the name that this server will use to identify itself. This +is the string that is sent with the I response header. The +main reason to have this method is that subclasses can override it if +they want to use another product name. + +=cut + +sub product_tokens +{ + "libwww-perl-daemon/$HTTP::Daemon::VERSION"; +} + + +package HTTP::Daemon::ClientConn; + +use vars qw(@ISA $DEBUG); +use IO::Socket (); +@ISA=qw(IO::Socket::INET); +*DEBUG = \$HTTP::Daemon::DEBUG; + +use HTTP::Request (); +use HTTP::Response (); +use HTTP::Status; +use HTTP::Date qw(time2str); +use LWP::MediaTypes qw(guess_media_type); +use Carp (); + +my $CRLF = "\015\012"; # "\r\n" is not portable +my $HTTP_1_0 = _http_version("HTTP/1.0"); +my $HTTP_1_1 = _http_version("HTTP/1.1"); + +=back + +The I is also a I +subclass. Instances of this class are returned by the accept() method +of I. The following additional methods are +provided: + +=over 4 + +=item $c->get_request([$headers_only]) + +Read data from the client and turn it into an +I object which is then returned. It returns C +if reading of the request fails. If it fails, then the +I object ($c) should be discarded, and you +should not call this method again. The $c->reason method might give +you some information about why $c->get_request returned C. + +The $c->get_request method supports HTTP/1.1 request content bodies, +including I transfer encoding with footer and self delimiting +I content types. + +The $c->get_request method will normally not return until the whole +request has been received from the client. This might not be what you +want if the request is an upload of a multi-mega-byte file (and with +chunked transfer encoding HTTP can even support infinite request +messages - uploading live audio for instance). If you pass a TRUE +value as the $headers_only argument, then $c->get_request will return +immediately after parsing the request headers and you are responsible +for reading the rest of the request content. If you are going to +call $c->get_request again on the same connection you better read the +correct number of bytes. + +=cut + +sub get_request +{ + my($self, $only_headers) = @_; + if (${*$self}{'httpd_nomore'}) { + $self->reason("No more requests from this connection"); + return; + } + + $self->reason(""); + my $buf = ${*$self}{'httpd_rbuf'}; + $buf = "" unless defined $buf; + + my $timeout = $ {*$self}{'io_socket_timeout'}; + my $fdset = ""; + vec($fdset, $self->fileno, 1) = 1; + local($_); + + READ_HEADER: + while (1) { + # loop until we have the whole header in $buf + $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines + if ($buf =~ /\012/) { # potential, has at least one line + if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { + if ($buf =~ /\015?\012\015?\012/) { + last READ_HEADER; # we have it + } elsif (length($buf) > 16*1024) { + $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE + $self->reason("Very long header"); + return; + } + } else { + last READ_HEADER; # HTTP/0.9 client + } + } elsif (length($buf) > 16*1024) { + $self->send_error(414); # REQUEST_URI_TOO_LARGE + $self->reason("Very long first line"); + return; + } + print STDERR "Need more data for complete header\n" if $DEBUG; + return unless $self->_need_more($buf, $timeout, $fdset); + } + if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { + ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); + $self->send_error(400); # BAD_REQUEST + $self->reason("Bad request line: $buf"); + return; + } + my $method = $1; + my $uri = $2; + my $proto = $3 || "HTTP/0.9"; + $uri = "http://$uri" if $method eq "CONNECT"; + $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url); + my $r = HTTP::Request->new($method, $uri); + $r->protocol($proto); + ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); + + if ($proto >= $HTTP_1_0) { + # we expect to find some headers + my($key, $val); + HEADER: + while ($buf =~ s/^([^\012]*)\012//) { + $_ = $1; + s/\015$//; + if (/^([\w\-]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } elsif (/^\s+(.*)/) { + $val .= " $1"; + } else { + last HEADER; + } + } + $r->push_header($key, $val) if $key; + } + + my $conn = $r->header('Connection'); + if ($proto >= $HTTP_1_1) { + ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/; + } else { + ${*$self}{'httpd_nomore'}++ unless $conn && + lc($conn) =~ /\bkeep-alive\b/; + } + + if ($only_headers) { + ${*$self}{'httpd_rbuf'} = $buf; + return $r; + } + + # Find out how much content to read + my $te = $r->header('Transfer-Encoding'); + my $ct = $r->header('Content-Type'); + my $len = $r->header('Content-Length'); + + if ($te && lc($te) eq 'chunked') { + # Handle chunked transfer encoding + my $body = ""; + CHUNK: + while (1) { + print STDERR "Chunked\n" if $DEBUG; + if ($buf =~ s/^([^\012]*)\012//) { + my $chunk_head = $1; + unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) { + $self->send_error(400); + $self->reason("Bad chunk header $chunk_head"); + return; + } + my $size = hex($1); + last CHUNK if $size == 0; + + my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end + # must read until we have a complete chunk + while ($missing > 0) { + print STDERR "Need $missing more bytes\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + $body .= substr($buf, 0, $size); + substr($buf, 0, $size+2) = ''; + + } else { + # need more data in order to have a complete chunk header + return unless $self->_need_more($buf, $timeout, $fdset); + } + } + $r->content($body); + + # pretend it was a normal entity body + $r->remove_header('Transfer-Encoding'); + $r->header('Content-Length', length($body)); + + my($key, $val); + FOOTER: + while (1) { + if ($buf !~ /\012/) { + # need at least one line to look at + return unless $self->_need_more($buf, $timeout, $fdset); + } else { + $buf =~ s/^([^\012]*)\012//; + $_ = $1; + s/\015$//; + if (/^([\w\-]+)\s*:\s*(.*)/) { + $r->push_header($key, $val) if $key; + ($key, $val) = ($1, $2); + } elsif (/^\s+(.*)/) { + $val .= " $1"; + } elsif (!length) { + last FOOTER; + } else { + $self->reason("Bad footer syntax"); + return; + } + } + } + $r->push_header($key, $val) if $key; + + } elsif ($te) { + $self->send_error(501); # Unknown transfer encoding + $self->reason("Unknown transfer encoding '$te'"); + return; + + } elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) { + # Handle multipart content type + my $boundary = "$CRLF--$1--$CRLF"; + my $index; + while (1) { + $index = index($buf, $boundary); + last if $index >= 0; + # end marker not yet found + return unless $self->_need_more($buf, $timeout, $fdset); + } + $index += length($boundary); + $r->content(substr($buf, 0, $index)); + substr($buf, 0, $index) = ''; + + } elsif ($len) { + # Plain body specified by "Content-Length" + my $missing = $len - length($buf); + while ($missing > 0) { + print "Need $missing more bytes of content\n" if $DEBUG; + my $n = $self->_need_more($buf, $timeout, $fdset); + return unless $n; + $missing -= $n; + } + if (length($buf) > $len) { + $r->content(substr($buf,0,$len)); + substr($buf, 0, $len) = ''; + } else { + $r->content($buf); + $buf=''; + } + } + ${*$self}{'httpd_rbuf'} = $buf; + + $r; +} + +sub _need_more +{ + my $self = shift; + #my($buf,$timeout,$fdset) = @_; + if ($_[1]) { + my($timeout, $fdset) = @_[1,2]; + print STDERR "select(,,,$timeout)\n" if $DEBUG; + my $n = select($fdset,undef,undef,$timeout); + unless ($n) { + $self->reason(defined($n) ? "Timeout" : "select: $!"); + return; + } + } + print STDERR "sysread()\n" if $DEBUG; + my $n = sysread($self, $_[0], 2048, length($_[0])); + $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + $n; +} + +=item $c->read_buffer([$new_value]) + +Bytes read by $c->get_request, but not used are placed in the I. The next time $c->get_request is called it will consume the +bytes in this buffer before reading more data from the network +connection itself. The read buffer is invalid after $c->get_request +has returned an undefined value. + +If you handle the reading of the request content yourself you need to +empty this buffer before you read more and you need to place +unconsumed bytes here. You also need this buffer if you implement +services like I<101 Switching Protocols>. + +This method always return the old buffer content and can optionally +replace the buffer content if you pass it an argument. + +=cut + +sub read_buffer +{ + my $self = shift; + my $old = ${*$self}{'httpd_rbuf'}; + if (@_) { + ${*$self}{'httpd_rbuf'} = shift; + } + $old; +} + + +=item $c->reason + +When $c->get_request returns C you can obtain a short string +describing why it happened by calling $c->reason. + +=cut + +sub reason +{ + my $self = shift; + my $old = ${*$self}{'httpd_reason'}; + if (@_) { + ${*$self}{'httpd_reason'} = shift; + } + $old; +} + + +=item $c->proto_ge($proto) + +Return TRUE if the client announced a protocol with version number +greater or equal to the given argument. The $proto argument can be a +string like "HTTP/1.1" or just "1.1". + +=cut + +sub proto_ge +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} >= _http_version(shift); +} + +sub _http_version +{ + local($_) = shift; + return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i; + $1 * 1000 + $2; +} + +=item $c->antique_client + +Return TRUE if the client speaks the HTTP/0.9 protocol. No status +code and no headers should be returned to such a client. This should +be the same as !$c->proto_ge("HTTP/1.0"). + +=cut + +sub antique_client +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} < $HTTP_1_0; +} + + +=item $c->force_last_request + +Make sure that $c->get_request will not try to read more requests off +this connection. If you generate a response that is not self +delimiting, then you should signal this fact by calling this method. + +This attribute is turned on automatically if the client announces +protocol HTTP/1.0 or worse and does not include a "Connection: +Keep-Alive" header. It is also turned on automatically when HTTP/1.1 +or better clients send the "Connection: close" request header. + +=cut + +sub force_last_request +{ + my $self = shift; + ${*$self}{'httpd_nomore'}++; +} + + +=item $c->send_status_line( [$code, [$mess, [$proto]]] ) + +Send the status line back to the client. If $code is omitted 200 is +assumed. If $mess is omitted, then a message corresponding to $code +is inserted. If $proto is missing the content of the +$HTTP::Daemon::PROTO variable is used. + +=cut + +sub send_status_line +{ + my($self, $status, $message, $proto) = @_; + return if $self->antique_client; + $status ||= RC_OK; + $message ||= status_message($status) || ""; + $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; + print $self "$proto $status $message$CRLF"; +} + +=item $c->send_crlf + +Send the CRLF sequence to the client. + +=cut + + +sub send_crlf +{ + my $self = shift; + print $self $CRLF; +} + + +=item $c->send_basic_header( [$code, [$mess, [$proto]]] ) + +Send the status line and the "Date:" and "Server:" headers back to +the client. This header is assumed to be continued and does not end +with an empty CRLF line. + +=cut + +sub send_basic_header +{ + my $self = shift; + return if $self->antique_client; + $self->send_status_line(@_); + print $self "Date: ", time2str(time), $CRLF; + my $product = $self->daemon->product_tokens; + print $self "Server: $product$CRLF" if $product; +} + + +=item $c->send_response( [$res] ) + +Write a I object to the +client as a response. We try hard to make sure that the response is +self delimiting so that the connection can stay persistent for further +request/response exchanges. + +The content attribute of the I object can be a normal +string or a subroutine reference. If it is a subroutine, then +whatever this callback routine returns is written back to the +client as the response content. The routine will be called until it +return an undefined or empty value. If the client is HTTP/1.1 aware +then we will use chunked transfer encoding for the response. + +=cut + +sub send_response +{ + my $self = shift; + my $res = shift; + if (!ref $res) { + $res ||= RC_OK; + $res = HTTP::Response->new($res, @_); + } + my $content = $res->content; + my $chunked; + unless ($self->antique_client) { + my $code = $res->code; + $self->send_basic_header($code, $res->message, $res->protocol); + if ($code =~ /^(1\d\d|[23]04)$/) { + # make sure content is empty + $res->remove_header("Content-Length"); + $content = ""; + } elsif ($res->request && $res->request->method eq "HEAD") { + # probably OK + } elsif (ref($content) eq "CODE") { + if ($self->proto_ge("HTTP/1.1")) { + $res->push_header("Transfer-Encoding" => "chunked"); + $chunked++; + } else { + $self->force_last_request; + } + } elsif (length($content)) { + $res->header("Content-Length" => length($content)); + } else { + $self->force_last_request; + } + print $self $res->headers_as_string($CRLF); + print $self $CRLF; # separates headers and content + } + if (ref($content) eq "CODE") { + while (1) { + my $chunk = &$content(); + last unless defined($chunk) && length($chunk); + if ($chunked) { + printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF; + } else { + print $self $chunk; + } + } + print $self "0$CRLF$CRLF" if $chunked; # no trailers either + } elsif (length $content) { + print $self $content; + } +} + + +=item $c->send_redirect( $loc, [$code, [$entity_body]] ) + +Send a redirect response back to the client. The location ($loc) can +be an absolute or relative URL. The $code must be one the redirect +status codes, and defaults to "301 Moved Permanently" + +=cut + +sub send_redirect +{ + my($self, $loc, $status, $content) = @_; + $status ||= RC_MOVED_PERMANENTLY; + Carp::croak("Status '$status' is not redirect") unless is_redirect($status); + $self->send_basic_header($status); + my $base = $self->daemon->url; + $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc); + $loc = $loc->abs($base); + print $self "Location: $loc$CRLF"; + if ($content) { + my $ct = $content =~ /^\s*force_last_request; # no use keeping the connection open +} + + +=item $c->send_error( [$code, [$error_message]] ) + +Send an error response back to the client. If the $code is missing a +"Bad Request" error is reported. The $error_message is a string that +is incorporated in the body of the HTML entity body. + +=cut + +sub send_error +{ + my($self, $status, $error) = @_; + $status ||= RC_BAD_REQUEST; + Carp::croak("Status '$status' is not an error") unless is_error($status); + my $mess = status_message($status); + $error ||= ""; + $mess = <$status $mess +

$status $mess

+$error +EOT + unless ($self->antique_client) { + $self->send_basic_header($status); + print $self "Content-Type: text/html$CRLF"; + print $self "Content-Length: " . length($mess) . $CRLF; + print $self $CRLF; + } + print $self $mess; + $status; +} + + +=item $c->send_file_response($filename) + +Send back a response with the specified $filename as content. If the +file is a directory we try to generate an HTML index of it. + +=cut + +sub send_file_response +{ + my($self, $file) = @_; + if (-d $file) { + $self->send_dir($file); + } elsif (-f _) { + # plain file + local(*F); + sysopen(F, $file, 0) or + return $self->send_error(RC_FORBIDDEN); + binmode(F); + my($ct,$ce) = guess_media_type($file); + my($size,$mtime) = (stat _)[7,9]; + unless ($self->antique_client) { + $self->send_basic_header; + print $self "Content-Type: $ct$CRLF"; + print $self "Content-Encoding: $ce$CRLF" if $ce; + print $self "Content-Length: $size$CRLF" if $size; + print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; + print $self $CRLF; + } + $self->send_file(\*F); + return RC_OK; + } else { + $self->send_error(RC_NOT_FOUND); + } +} + + +sub send_dir +{ + my($self, $dir) = @_; + $self->send_error(RC_NOT_FOUND) unless -d $dir; + $self->send_error(RC_NOT_IMPLEMENTED); +} + + +=item $c->send_file($fd); + +Copy the file to the client. The file can be a string (which +will be interpreted as a filename) or a reference to an I +or glob. + +=cut + +sub send_file +{ + my($self, $file) = @_; + my $opened = 0; + if (!ref($file)) { + local(*F); + open(F, $file) || return undef; + binmode(F); + $file = \*F; + $opened++; + } + my $cnt = 0; + my $buf = ""; + my $n; + while ($n = sysread($file, $buf, 8*1024)) { + last if !$n; + $cnt += $n; + print $self $buf; + } + close($file) if $opened; + $cnt; +} + + +=item $c->daemon + +Return a reference to the corresponding I object. + +=cut + +sub daemon +{ + my $self = shift; + ${*$self}{'httpd_daemon'}; +} + +=back + +=head1 SEE ALSO + +RFC 2068 + +L, L + +=head1 COPYRIGHT + +Copyright 1996-2001, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; Index: /branches/mt4.11/extlib/HTTP/Status.pm =================================================================== --- /branches/mt4.11/extlib/HTTP/Status.pm (revision 1098) +++ /branches/mt4.11/extlib/HTTP/Status.pm (revision 1098) @@ -0,0 +1,244 @@ +# +# $Id: Status.pm,v 1.26 1999/11/22 10:43:24 gisle Exp $ + +package HTTP::Status; + +use strict; +require 5.002; # becase we use prototypes + +=head1 NAME + +HTTP::Status - HTTP Status code processing + +=head1 SYNOPSIS + + use HTTP::Status; + + if ($rc != RC_OK) { + print status_message($rc), "\n"; + } + + if (is_success($rc)) { ... } + if (is_error($rc)) { ... } + if (is_redirect($rc)) { ... } + +=head1 DESCRIPTION + +I is a library of routines for defining and +classifying HTTP status codes for libwww-perl. Status codes are +used to encode the overall outcome of a HTTP response message. Codes +correspond to those defined in RFC 2616 and RFC 2518. + +=head1 CONSTANTS + +The following constant functions can be used as mnemonic status code +names: + + RC_CONTINUE (100) + RC_SWITCHING_PROTOCOLS (101) + RC_PROCESSING (102) + + RC_OK (200) + RC_CREATED (201) + RC_ACCEPTED (202) + RC_NON_AUTHORITATIVE_INFORMATION (203) + RC_NO_CONTENT (204) + RC_RESET_CONTENT (205) + RC_PARTIAL_CONTENT (206) + RC_MULTI_STATUS (207) + + RC_MULTIPLE_CHOICES (300) + RC_MOVED_PERMANENTLY (301) + RC_FOUND (302) + RC_SEE_OTHER (303) + RC_NOT_MODIFIED (304) + RC_USE_PROXY (305) + RC_TEMPORARY_REDIRECT (307) + + RC_BAD_REQUEST (400) + RC_UNAUTHORIZED (401) + RC_PAYMENT_REQUIRED (402) + RC_FORBIDDEN (403) + RC_NOT_FOUND (404) + RC_METHOD_NOT_ALLOWED (405) + RC_NOT_ACCEPTABLE (406) + RC_PROXY_AUTHENTICATION_REQUIRED (407) + RC_REQUEST_TIMEOUT (408) + RC_CONFLICT (409) + RC_GONE (410) + RC_LENGTH_REQUIRED (411) + RC_PRECONDITION_FAILED (412) + RC_REQUEST_ENTITY_TOO_LARGE (413) + RC_REQUEST_URI_TOO_LARGE (414) + RC_UNSUPPORTED_MEDIA_TYPE (415) + RC_REQUEST_RANGE_NOT_SATISFIABLE (416) + RC_EXPECTATION_FAILED (417) + RC_UNPROCESSABLE_ENTITY (422) + RC_LOCKED (423) + RC_FAILED_DEPENDENCY (424) + + RC_INTERNAL_SERVER_ERROR (500) + RC_NOT_IMPLEMENTED (501) + RC_BAD_GATEWAY (502) + RC_SERVICE_UNAVAILABLE (503) + RC_GATEWAY_TIMEOUT (504) + RC_HTTP_VERSION_NOT_SUPPORTED (505) + RC_INSUFFICIENT_STORAGE (507) + +=cut + +##################################################################### + +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(is_info is_success is_redirect is_error status_message); +@EXPORT_OK = qw(is_client_error is_server_error); +$VERSION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/); + +# Note also addition of mnemonics to @EXPORT below + +my %StatusCode = ( + 100 => 'Continue', + 101 => 'Switching Protocols', + 102 => 'Processing', # WebDAV + 200 => 'OK', + 201 => 'Created', + 202 => 'Accepted', + 203 => 'Non-Authoritative Information', + 204 => 'No Content', + 205 => 'Reset Content', + 206 => 'Partial Content', + 207 => 'Multi-Status', # WebDAV + 300 => 'Multiple Choices', + 301 => 'Moved Permanently', + 302 => 'Found', + 303 => 'See Other', + 304 => 'Not Modified', + 305 => 'Use Proxy', + 307 => 'Temporary Redirect', + 400 => 'Bad Request', + 401 => 'Unauthorized', + 402 => 'Payment Required', + 403 => 'Forbidden', + 404 => 'Not Found', + 405 => 'Method Not Allowed', + 406 => 'Not Acceptable', + 407 => 'Proxy Authentication Required', + 408 => 'Request Timeout', + 409 => 'Conflict', + 410 => 'Gone', + 411 => 'Length Required', + 412 => 'Precondition Failed', + 413 => 'Request Entity Too Large', + 414 => 'Request-URI Too Large', + 415 => 'Unsupported Media Type', + 416 => 'Request Range Not Satisfiable', + 417 => 'Expectation Failed', + 422 => 'Unprocessable Entity', # WebDAV + 423 => 'Locked', # WebDAV + 424 => 'Failed Dependency', # WebDAV + 500 => 'Internal Server Error', + 501 => 'Not Implemented', + 502 => 'Bad Gateway', + 503 => 'Service Unavailable', + 504 => 'Gateway Timeout', + 505 => 'HTTP Version Not Supported', + 507 => 'Insufficient Storage', # WebDAV +); + +my $mnemonicCode = ''; +my ($code, $message); +while (($code, $message) = each %StatusCode) { + # create mnemonic subroutines + $message =~ tr/a-z \-/A-Z__/; + $mnemonicCode .= "sub RC_$message () { $code }\t"; + # make them exportable + $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n"; +} +# warn $mnemonicCode; # for development +eval $mnemonicCode; # only one eval for speed +die if $@; + +# backwards compatibility +*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard +push(@EXPORT, "RC_MOVED_TEMPORARILY"); + + +=head1 FUNCTIONS + +The following additional functions are provided. Most of them are +exported by default. + +=over 4 + +=item status_message($code) + +The status_message() function will translate status codes to human +readable strings. The string is the same as found in the constant +names above. If the $code is unknown, then C is returned. + +=cut + +sub status_message ($) +{ + $StatusCode{$_[0]}; +} + +=item is_info($code) + +Return TRUE if C<$code> is an I status code. This +class of status code indicates a provisional response which can't have +any content. + +=item is_success($code) + +Return TRUE if C<$code> is a I status code. + +=item is_redirect($code) + +Return TRUE if C<$code> is a I status code. This class of +status code indicates that further action needs to be taken by the +user agent in order to fulfill the request. + +=item is_error($code) + +Return TRUE if C<$code> is an I status code. The function +return TRUE for both client error or a server error status codes. + +=item is_client_error($code) + +Return TRUE if C<$code> is an I status code. This class +of status code is intended for cases in which the client seems to have +erred. + +This function is B exported by default. + +=item is_server_error($code) + +Return TRUE if C<$code> is an I status code. This class +of status codes is intended for cases in which the server is aware +that it has erred or is incapable of performing the request. + +This function is B exported by default. + +=back + +=cut + +sub is_info ($) { $_[0] >= 100 && $_[0] < 200; } +sub is_success ($) { $_[0] >= 200 && $_[0] < 300; } +sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; } +sub is_error ($) { $_[0] >= 400 && $_[0] < 600; } +sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; } +sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; } + +1; + +=head1 BUGS + +Wished @EXPORT_OK had been used instead of @EXPORT in the beginning. +Now too much is exported by default. + +=cut Index: /branches/mt4.11/extlib/Apache/XMLRPC/Lite.pm =================================================================== --- /branches/mt4.11/extlib/Apache/XMLRPC/Lite.pm (revision 1098) +++ /branches/mt4.11/extlib/Apache/XMLRPC/Lite.pm (revision 1098) @@ -0,0 +1,131 @@ +# ====================================================================== +# +# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com) +# SOAP::Lite is free software; you can redistribute it +# and/or modify it under the same terms as Perl itself. +# +# $Id: Lite.pm,v 1.3 2001/08/11 19:09:57 paulk Exp $ +# +# ====================================================================== + +package Apache::XMLRPC::Lite; + +use strict; +use vars qw(@ISA $VERSION); +use XMLRPC::Transport::HTTP; + +@ISA = qw(XMLRPC::Transport::HTTP::Apache); +$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); + +my $server = __PACKAGE__->new; + +sub handler { + $server->configure(@_); + $server->SUPER::handler(@_); +} + +# ====================================================================== + +1; + +__END__ + +=head1 NAME + +Apache::XMLRPC::Lite - mod_perl-based XML-RPC server with minimum configuration + +=head1 SYNOPSIS + +=over 4 + +=item httpd.conf (Location), directory-based access + + + SetHandler perl-script + PerlHandler Apache::XMLRPC::Lite + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + + +=item httpd.conf (Files), file-based access + + + SetHandler perl-script + PerlHandler Apache::XMLRPC::Lite + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + + +=item .htaccess, directory-based access + + SetHandler perl-script + PerlHandler Apache::XMLRPC::Lite + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + +=back + +=head1 DESCRIPTION + +This Apache Perl module provides the ability to add support for XML-RPC +protocol with easy configuration (either in .conf or in .htaccess file). +This functionality should give you lightweight option +for hosting SOAP services and greatly simplify configuration aspects. This +module inherites functionality from XMLRPC::Transport::HTTP::Apache component +of XMLRPC::Lite module. + +=head1 CONFIGURATION + +The module can be placed in , , , +directives in main server configuration areas or directly in .htaccess file. + +All parameters should be quoted and can be separated with commas or spaces +for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters +("key1 => value1, key2 => value2"). + +All options that you can find in XMLRPC::Transport::HTTP::Apache component +are available for configuration. Here is the description of most important +ones. + +=over 4 + +=item dispatch_to (LIST) + +Specifies path to directory that contains Perl modules you'd like to give +access to, or just list of modules (for preloaded modules). + + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + +=item options (HASH) + +Specifies list of options for your module, for example threshold for +compression. Future versions will support more options. See +XMLRPC::Transport::HTTP documentation for other options. + + PerlSetVar options "compress_threshold => 10000" + +=back + +=head1 DEPENDENCIES + + XMLRPC::Lite + mod_perl + +=head1 SEE ALSO + + XMLRPC::Transport::HTTP::Apache for implementation details, + XMLRPC::Lite for general information, and + F for .htaccess example + +=head1 COPYRIGHT + +Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Paul Kulchenko (paulclinger@yahoo.com) + +=cut Index: /branches/mt4.11/extlib/Apache/SOAP.pm =================================================================== --- /branches/mt4.11/extlib/Apache/SOAP.pm (revision 1098) +++ /branches/mt4.11/extlib/Apache/SOAP.pm (revision 1098) @@ -0,0 +1,131 @@ +# ====================================================================== +# +# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com) +# SOAP::Lite is free software; you can redistribute it +# and/or modify it under the same terms as Perl itself. +# +# $Id: SOAP.pm,v 1.3 2001/08/11 19:09:57 paulk Exp $ +# +# ====================================================================== + +package Apache::SOAP; + +use strict; +use vars qw(@ISA $VERSION); +use SOAP::Transport::HTTP; + +@ISA = qw(SOAP::Transport::HTTP::Apache); +$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); + +my $server = __PACKAGE__->new; + +sub handler { + $server->configure(@_); + $server->SUPER::handler(@_); +} + +# ====================================================================== + +1; + +__END__ + +=head1 NAME + +Apache::SOAP - mod_perl-based SOAP server with minimum configuration + +=head1 SYNOPSIS + +=over 4 + +=item httpd.conf (Location), directory-based access + + + SetHandler perl-script + PerlHandler Apache::SOAP + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + + +=item httpd.conf (Files), file-based access + + + SetHandler perl-script + PerlHandler Apache::SOAP + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + + +=item .htaccess, directory-based access + + SetHandler perl-script + PerlHandler Apache::SOAP + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + PerlSetVar options "compress_threshold => 10000" + +=back + +=head1 DESCRIPTION + +This Apache Perl module provides the ability to add support for SOAP (Simple +Object Access Protocol) protocol with easy configuration (either in .conf or +in .htaccess file). This functionality should give you lightweight option +for hosting SOAP services and greatly simplify configuration aspects. This +module inherites functionality from SOAP::Transport::HTTP::Apache component +of SOAP::Lite module. + +=head1 CONFIGURATION + +The module can be placed in , , , +directives in main server configuration areas or directly in .htaccess file. + +All parameters should be quoted and can be separated with commas or spaces +for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters +("key1 => value1, key2 => value2"). + +All options that you can find in SOAP::Transport::HTTP::Apache component +are available for configuration. Here is the description of most important +ones. + +=over 4 + +=item dispatch_to (LIST) + +Specifies path to directory that contains Perl modules you'd like to give +access to, or just list of modules (for preloaded modules). + + PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" + +=item options (HASH) + +Specifies list of options for your module, for example threshold for +compression. Future versions will support more options. See +SOAP::Transport::HTTP documentation for other options. + + PerlSetVar options "compress_threshold => 10000" + +=back + +=head1 DEPENDENCIES + + SOAP::Lite + mod_perl + +=head1 SEE ALSO + + SOAP::Transport::HTTP::Apache for implementation details, + SOAP::Lite for general information, and + F for .htaccess example + +=head1 COPYRIGHT + +Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Paul Kulchenko (paulclinger@yahoo.com) + +=cut Index: /branches/mt4.11/extlib/Archive/Extract.pm =================================================================== --- /branches/mt4.11/extlib/Archive/Extract.pm (revision 1098) +++ /branches/mt4.11/extlib/Archive/Extract.pm (revision 1098) @@ -0,0 +1,950 @@ +package Archive::Extract; + +use strict; + +use Cwd qw[cwd]; +use Carp qw[carp]; +use IPC::Cmd qw[run can_run]; +use FileHandle; +use File::Path qw[mkpath]; +use File::Spec; +use File::Basename qw[dirname basename]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Style => 'gettext'; + +### solaris has silly /bin/tar output ### +use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0; +use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; + +use constant TGZ => 'tgz'; +use constant TAR => 'tar'; +use constant GZ => 'gz'; +use constant ZIP => 'zip'; + +use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG]; + +$VERSION = '0.08'; +$PREFER_BIN = 0; +$WARN = 1; +$DEBUG = 0; + +local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +Archive::Extract -- A generic archive extracting mechanism + +=head1 SYNOPSIS + + use Archive::Extract; + + ### build an Archive::Extract object ### + my $ae = Archive::Extract->new( archive => 'foo.tgz' ); + + ### extract to cwd() ### + my $ok = $ae->extract; + + ### extract to /tmp ### + my $ok = $ae->extract( to => '/tmp' ); + + ### what if something went wrong? + my $ok = $ae->extract or die $ae->error; + + ### files from the archive ### + my $files = $ae->files; + + ### dir that was extracted to ### + my $outdir = $ae->extract_path; + + + ### quick check methods ### + $ae->is_tar # is it a .tar file? + $ae->is_tgz # is it a .tar.gz or .tgz file? + $ae->is_gz; # is it a .gz file? + $ae->is_zip; # is it a .zip file? + + ### absolute path to the archive you provided ### + $ae->archive; + + ### commandline tools, if found ### + $ae->bin_tar # path to /bin/tar, if found + $ae->bin_gzip # path to /bin/gzip, if found + $ae->bin_unzip # path to /bin/unzip, if found + +=head1 DESCRIPTION + +Archive::Extract is a generic archive extraction mechanism. + +It allows you to extract any archive file of the type .tar, .tar.gz, +.gz or .zip without having to worry how it does so, or use different +interfaces for each type by using either perl modules, or commandline +tools on your system. + +See the C section further down for details. + +=cut + + +### see what /bin/programs are available ### +$PROGRAMS = {}; +for my $pgm (qw[tar unzip gzip]) { + $PROGRAMS->{$pgm} = can_run($pgm); +} + +### mapping from types to extractor methods ### +my $Mapping = { + is_tgz => '_untar', + is_tar => '_untar', + is_gz => '_gunzip', + is_zip => '_unzip', +}; + +{ + my $tmpl = { + archive => { required => 1, allow => FILE_EXISTS }, + type => { default => '', allow => [qw|tgz tar zip gz|] }, + }; + + ### build accesssors ### + for my $method( keys %$tmpl, + qw[_extractor _gunzip_to files extract_path] + ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method} = $_[0] if @_; + return $self->{$method}; + } + } + +=head1 METHODS + +=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) + +Creates a new C object based on the archive file you +passed it. Automatically determines the type of archive based on the +extension, but you can override that by explicitly providing the +C argument. + +Valid values for C are: + +=over 4 + +=item tar + +Standard tar files, as produced by, for example, C. +Corresponds to a C<.tar> suffix. + +=item tgz + +Gzip compressed tar files, as produced by, for example C. +Corresponds to a C<.tgz> or C<.tar.gz> suffix. + +=item gz + +Gzip compressed file, as produced by, for example C. +Corresponds to a C<.gz> suffix. + +=item zip + +Zip compressed file, as produced by, for example C. +Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. + +=back + +Returns a C object on success, or false on failure. + +=cut + + ### constructor ### + sub new { + my $class = shift; + my %hash = @_; + + my $parsed = check( $tmpl, \%hash ) or return; + + ### make sure we have an absolute path ### + my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); + + ### figure out the type, if it wasn't already specified ### + unless ( $parsed->{type} ) { + $parsed->{type} = + $ar =~ /.+?\.(?:tar\.gz)|tgz$/i ? TGZ : + $ar =~ /.+?\.gz$/i ? GZ : + $ar =~ /.+?\.tar$/i ? TAR : + $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP : + ''; + + } + + ### don't know what type of file it is ### + return __PACKAGE__->_error(loc("Cannot determine file type for '%1'", + $parsed->{archive} )) unless $parsed->{type}; + + return bless $parsed, $class; + } +} + +=head2 $ae->extract( [to => '/output/path'] ) + +Extracts the archive represented by the C object to +the path of your choice as specified by the C argument. Defaults to +C. + +Since C<.gz> files never hold a directory, but only a single file; if +the C argument is an existing directory, the file is extracted +there, with it's C<.gz> suffix stripped. +If the C argument is not an existing directory, the C argument +is understood to be a filename, if the archive type is C. +In the case that you did not specify a C argument, the output +file will be the name of the archive file, stripped from it's C<.gz> +suffix, in the current working directory. + +C will try a pure perl solution first, and then fall back to +commandline tools if they are available. See the C +section below on how to alter this behaviour. + +It will return true on success, and false on failure. + +On success, it will also set the follow attributes in the object: + +=over 4 + +=item $ae->extract_path + +This is the directory that the files where extracted to. + +=item $ae->files + +This is an array ref with the paths of all the files in the archive, +relative to the C argument you specified. +To get the full path to an extracted file, you would use: + + File::Spec->catfile( $to, $ae->files->[0] ); + +Note that all files from a tar archive will be in unix format, as per +the tar specification. + +=back + +=cut + +sub extract { + my $self = shift; + my %hash = @_; + + my $to; + my $tmpl = { + to => { default => '.', store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + ### so 'to' could be a file or a dir, depending on whether it's a .gz + ### file, or basically anything else. + ### so, check that, then act accordingly. + ### set an accessor specifically so _gunzip can know what file to extract + ### to. + my $dir; + { ### a foo.gz file + if( $self->is_gz ) { + + my $cp = $self->archive; $cp =~ s/\.gz$//i; + + ### to is a dir? + if ( -d $to ) { + $dir = $to; + $self->_gunzip_to( basename($cp) ); + + ### then it's a filename + } else { + $dir = dirname($to); + $self->_gunzip_to( basename($to) ); + } + + ### not a foo.gz file + } else { + $dir = $to; + } + } + + ### make the dir if it doesn't exist ### + unless( -d $dir ) { + eval { mkpath( $dir ) }; + + return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) + if $@; + } + + ### get the current dir, to restore later ### + my $cwd = cwd(); + + my $ok = 1; + EXTRACT: { + + ### chdir to the target dir ### + unless( chdir $dir ) { + $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); + $ok = 0; last EXTRACT; + } + + ### find what extractor method to use ### + while( my($type,$method) = each %$Mapping ) { + + ### call the corresponding method if the type is OK ### + if( $self->$type) { + $ok = $self->$method(); + } + } + + ### warn something went wrong if we didn't get an OK ### + $self->_error(loc("Extract failed, no extractor found")) + unless $ok; + + } + + ### and chdir back ### + unless( chdir $cwd ) { + $self->_error(loc("Could not chdir back to start dir '%1': %2'", + $cwd, $!)); + } + + return $ok; +} + +=pod + +=head1 ACCESSORS + +=head2 $ae->error([BOOL]) + +Returns the last encountered error as string. +Pass it a true value to get the C output instead. + +=head2 $ae->extract_path + +This is the directory the archive got extracted to. +See C for details. + +=head2 $ae->files + +This is an array ref holding all the paths from the archive. +See C for details. + +=head2 $ae->archive + +This is the full path to the archive file represented by this +C object. + +=head2 $ae->type + +This is the type of archive represented by this C +object. See accessors below for an easier way to use this. +See the C method for details. + +=head2 $ae->is_tgz + +Returns true if the file is of type C<.tar.gz>. +See the C method for details. + +=head2 $ae->is_tar + +Returns true if the file is of type C<.tar>. +See the C method for details. + +=head2 $ae->is_gz + +Returns true if the file is of type C<.gz>. +See the C method for details. + +=head2 $ae->is_zip + +Returns true if the file is of type C<.zip>. +See the C method for details. + +=cut + +### quick check methods ### +sub is_tgz { return $_[0]->type eq TGZ } +sub is_tar { return $_[0]->type eq TAR } +sub is_gz { return $_[0]->type eq GZ } +sub is_zip { return $_[0]->type eq ZIP } + +=pod + +=head2 $ae->bin_tar + +Returns the full path to your tar binary, if found. + +=head2 $ae->bin_gzip + +Returns the full path to your gzip binary, if found + +=head2 $ae->bin_unzip + +Returns the full path to your unzip binary, if found + +=cut + +### paths to commandline tools ### +sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} } +sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} } +sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} } + + +################################# +# +# Untar code +# +################################# + + +### untar wrapper... goes to either Archive::Tar or /bin/tar +### depending on $PREFER_BIN +sub _untar { + my $self = shift; + + my @methods = qw[_untar_at _untar_bin]; + @methods = reverse @methods if $PREFER_BIN; + + for my $method (@methods) { + $self->_extractor($method) && return 1 if $self->$method(); + } + + return $self->_error(loc("Unable to untar file '%1'", $self->archive)); +} + +### use /bin/tar to extract ### +sub _untar_bin { + my $self = shift; + + ### check for /bin/tar ### + return $self->_error(loc("No '%1' program found", '/bin/tar')) + unless $self->bin_tar; + + ### check for /bin/gzip if we need it ### + return $self->_error(loc("No '%1' program found", '/bin/gzip')) + if $self->is_tgz && !$self->bin_gzip; + + ### XXX figure out how to make IPC::Run do this in one call -- + ### currently i don't know how to get output of a command after a pipe + ### trapped in a scalar. Mailed barries about this 5th of june 2004. + + + + ### see what command we should run, based on whether + ### it's a .tgz or .tar + + ### XXX solaris tar and bsdtar are having different outputs + ### depending whether you run with -x or -t + ### compensate for this insanity by running -t first, then -x + { my $cmd = $self->is_tgz + ? [$self->bin_gzip, '-cdf', $self->archive, '|', + $self->bin_tar, '-tf', '-'] + : [$self->bin_tar, '-tf', $self->archive]; + + ### run the command ### + my $buffer = ''; + unless( scalar run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ) + ) { + return $self->_error(loc( + "Error listing contents of archive '%1': %2", + $self->archive, $buffer )); + } + + unless( $buffer ) { + $self->_error(loc("No buffer captured, unable to tell ". + "extracted files or extraction dir for '%1'", + $self->archive)); + } else { + ### if we're on solaris we /might/ be using /bin/tar, which has + ### a weird output format... we might also be using + ### /usr/local/bin/tar, which is gnu tar, which is perfectly + ### fine... so we have to do some guessing here =/ + my @files = map { chomp; + !ON_SOLARIS ? $_ + : (m|^ x \s+ # 'xtract' -- sigh + (.+?), # the actual file name + \s+ [\d,.]+ \s bytes, + \s+ [\d,.]+ \s tape \s blocks + |x ? $1 : $_); + + } split $/, $buffer; + + ### store the files that are in the archive ### + $self->files(\@files); + } + } + + ### now actually extract it ### + { my $cmd = $self->is_tgz + ? [$self->bin_gzip, '-cdf', $self->archive, '|', + $self->bin_tar, '-xf', '-'] + : [$self->bin_tar, '-xf', $self->archive]; + + my $buffer = ''; + unless( scalar run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Error extracting archive '%1': %2", + $self->archive, $buffer )); + } + + ### we might not have them, due to lack of buffers + if( $self->files ) { + ### now that we've extracted, figure out where we extracted to + my $dir = $self->__get_extract_dir( $self->files ); + + ### store the extraction dir ### + $self->extract_path( $dir ); + } + } + + ### we got here, no error happened + return 1; +} + +### use archive::tar to extract ### +sub _untar_at { + my $self = shift; + + ### we definitely need A::T, so load that first + { my $use_list = { 'Archive::Tar' => '0.0' }; + + unless( can_load( modules => $use_list ) ) { + + return $self->_error(loc("You do not have '%1' installed - " . + "Please install it as soon as possible.", + 'Archive::Tar')); + } + } + + ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib + ### if A::T's version is 0.99 or higher + if( $self->is_tgz ) { + my $use_list = { 'Compress::Zlib' => '0.0' }; + $use_list->{ 'IO::Zlib' } = '0.0' + if $Archive::Tar::VERSION >= '0.99'; + + unless( can_load( modules => $use_list ) ) { + my $which = join '/', sort keys %$use_list; + + return $self->_error(loc( + "You do not have '%1' installed - Please ". + "install it as soon as possible.", $which)); + + } + } + + my $tar = Archive::Tar->new(); + + unless( $tar->read( $self->archive, $self->is_tgz ) ) { + return $self->_error(loc("Unable to read '%1': %2", $self->archive, + $Archive::Tar::error)); + } + + ### workaround to prevent Archive::Tar from setting uid, which + ### is a potential security hole. -autrijus + ### have to do it here, since A::T needs to be /loaded/ first ### + { no strict 'refs'; local $^W; + + ### older versions of archive::tar <= 0.23 + *Archive::Tar::chown = sub {}; + } + + ### for version of archive::tar > 1.04 + local $Archive::Tar::Constant::CHOWN = 0; + + { local $^W; # quell 'splice() offset past end of array' warnings + # on older versions of A::T + + ### older archive::tar always returns $self, return value slightly + ### fux0r3d because of it. + $tar->extract() + or return $self->_error(loc("Unable to extract '%1': %2", + $self->archive, $Archive::Tar::error )); + } + + my @files = $tar->list_files; + my $dir = $self->__get_extract_dir( \@files ); + + ### store the files that are in the archive ### + $self->files(\@files); + + ### store the extraction dir ### + $self->extract_path( $dir ); + + ### check if the dir actually appeared ### + return 1 if -d $self->extract_path; + + ### no dir, we failed ### + return $self->_error(loc("Unable to extract '%1': %2", + $self->archive, $Archive::Tar::error )); +} + +################################# +# +# Gunzip code +# +################################# + +### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip +### depending on $PREFER_BIN +sub _gunzip { + my $self = shift; + + my @methods = qw[_gunzip_cz _gunzip_bin]; + @methods = reverse @methods if $PREFER_BIN; + + for my $method (@methods) { + $self->_extractor($method) && return 1 if $self->$method(); + } + + return $self->_error(loc("Unable to gunzip file '%1'", $self->archive)); +} + +sub _gunzip_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + return $self->_error(loc("No '%1' program found", '/bin/gzip')) + unless $self->bin_gzip; + + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to gunzip '%1': %2", + $self->archive, $buffer)); + } + + unless( $buffer ) { + $self->_error(loc("No buffer captured, unable to get content for '%1'", + $self->archive)); + } + + print $fh $buffer if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _gunzip_cz { + my $self = shift; + + my $use_list = { 'Compress::Zlib' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + return $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::Zlib')); + } + + my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, $Compress::Zlib::gzerrno)); + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $buffer; + $fh->print($buffer) while $gz->gzread($buffer) > 0; + $fh->close; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# Unzip code +# +################################# + +### unzip wrapper... goes to either Archive::Zip or /bin/unzip +### depending on $PREFER_BIN +sub _unzip { + my $self = shift; + + my @methods = qw[_unzip_az _unzip_bin]; + @methods = reverse @methods if $PREFER_BIN; + + for my $method (@methods) { + $self->_extractor($method) && return 1 if $self->$method(); + } + + return $self->_error(loc("Unable to gunzip file '%1'", $self->archive)); +} + +sub _unzip_bin { + my $self = shift; + + ### check for /bin/gzip if we need it ### + return $self->_error(loc("No '%1' program found", '/bin/unzip')) + unless $self->bin_unzip; + + + ### first, get the files.. it must be 2 different commands with 'unzip' :( + { my $cmd = [ $self->bin_unzip, '-Z', '-1', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + unless( $buffer ) { + $self->_error(loc("No buffer captured, unable to tell extracted ". + "files or extraction dir for '%1'", + $self->archive)); + + } else { + $self->files( [split $/, $buffer] ); + } + } + + ### now, extract the archive ### + { my $cmd = [ $self->bin_unzip, '-qq', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + if( scalar @{$self->files} ) { + my $files = $self->files; + my $dir = $self->__get_extract_dir( $files ); + + $self->extract_path( $dir ); + } + } + + return 1; +} + +sub _unzip_az { + my $self = shift; + + my $use_list = { 'Archive::Zip' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + return $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Archive::Zip')); + } + + my $zip = Archive::Zip->new(); + + unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Unable to read '%1'", $self->archive)); + } + + my @files; + ### have to extract every memeber individually ### + for my $member ($zip->members) { + push @files, $member->{fileName}; + + unless( $zip->extractMember($member) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Extraction of '%1' from '%2' failed", + $member->{fileName}, $self->archive )); + } + } + + my $dir = $self->__get_extract_dir( \@files ); + + ### set what files where extract, and where they went ### + $self->files( \@files ); + $self->extract_path( File::Spec->rel2abs($dir) ); + + return 1; +} + +sub __get_extract_dir { + my $self = shift; + my $files = shift or return; + + my($dir1, $dir2); + for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { + my($dir,$pos) = @$aref; + + ### add a catdir(), so that any trailing slashes get + ### take care of (removed) + my $res = -d $files->[$pos] + ? File::Spec->catdir( $files->[$pos], '' ) + : dirname( $files->[$pos] ); + + $$dir = $res; + } + + ### if the first and last dir don't match, make sure the + ### dirname is not set wrongly + my $dir; + + ### dirs are the same, so we know for sure what the extract dir is + if( $dir1 eq $dir2 ) { + $dir = $dir1; + + ### dirs are different.. do they share the base dir? + ### if so, use that, if not, fall back to '.' + } else { + my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0]; + my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0]; + + $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' ); + } + + return File::Spec->rel2abs( $dir ); +} + + +################################# +# +# Error code +# +################################# + +### Error handling, the way Archive::Tar does it ### +{ + my $error = ''; + my $longmess = ''; + + sub _error { + my $self = shift; + $error = shift; + $longmess = Carp::longmess($error); + + ### set Archive::Tar::WARN to 0 to disable printing + ### of errors + if( $WARN ) { + carp $DEBUG ? $longmess : $error; + } + + return; + } + + sub error { + my $self = shift; + return shift() ? $longmess : $error; + } +} + +1; + +=pod + +=head1 HOW IT WORKS + +C tries first to determine what type of archive you +are passing it, by inspecting its suffix. It does not do this by using +Mime magic, or something related. See C below. + +Once it has determined the file type, it knows which extraction methods +it can use on the archive. It will try a perl solution first, then fall +back to a commandline tool if that fails. If that also fails, it will +return false, indicating it was unable to extract the archive. +See the section on C to see how to alter this order. + +=head1 CAVEATS + +C trusts on the extension of the archive to determine +what type it is, and what extractor methods therefore can be used. If +your archives do not have any of the extensions as described in the +C method, you will have to specify the type explicitly, or +C will not be able to extract the archive for you. + +=head1 GLOBAL VARIABLES + +=head2 $Archive::Extract::DEBUG + +Set this variable to C to have all calls to command line tools +be printed out, including all their output. +This also enables C errors, instead of the regular +C errors. + +Good for tracking down why things don't work with your particular +setup. + +Defaults to C. + +=head2 $Archive::Extract::WARN + +This variable controls whether errors encountered internally by +C should be C'd or not. + +Set to false to silence warnings. Inspect the output of the C +method manually to see what went wrong. + +Defaults to C. + +=head2 $Archive::Extract::PREFER_BIN + +This variables controls whether C should prefer the +use of perl modules, or commandline tools to extract archives. + +Set to C to have C prefer commandline tools. + +Defaults to C. + +=head1 TODO + +=over 4 + +=item bzip2 support + +Right now, bzip2 (.bz2/tar.bz2/tbz) files are completely unsupported. + +=item Mime magic support + +Maybe this module should use something like C to determine +the type, rather than blindly trust the suffix. + +=head1 AUTHORS + +This module by +Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This module is +copyright (c) 2004 Jos Boumans Ekane@cpan.orgE. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + Index: /branches/mt4.11/extlib/Params/ValidateXS.pm =================================================================== --- /branches/mt4.11/extlib/Params/ValidateXS.pm (revision 1098) +++ /branches/mt4.11/extlib/Params/ValidateXS.pm (revision 1098) @@ -0,0 +1,174 @@ +# Copyright (c) 2000-2004 Dave Rolsky +# All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. See the LICENSE +# file that comes with this distribution for more details. +package Params::Validate; + +use strict; + +require DynaLoader; + +if ( $] >= 5.006 ) +{ + require XSLoader; + XSLoader::load( 'Params::Validate', $Params::Validate::VERSION ); +} +else +{ + require DynaLoader; + push @ISA, 'DynaLoader'; + Params::Validate->bootstrap( $Params::Validate::VERSION ); +} + +my $default_fail = sub { require Carp; + Carp::confess($_[0]) }; + +{ + my %defaults = ( ignore_case => 0, + strip_leading => 0, + allow_extra => 0, + on_fail => $default_fail, + stack_skip => 1, + normalize_keys => undef, + ); + + *set_options = \&validation_options; + sub validation_options + { + my %opts = @_; + + my $caller = caller; + + foreach ( keys %defaults ) + { + $opts{$_} = $defaults{$_} unless exists $opts{$_}; + } + + $OPTIONS{$caller} = \%opts; + } +} + +sub _check_regex_from_xs { return $_[0] =~ /$_[1]/ ? 1 : 0 } + +BEGIN +{ + if ( $] >= 5.006 && $] < 5.007 ) + { + eval <<'EOF'; +sub check_for_error +{ + if ( defined $Params::Validate::ERROR ) + { + $Params::Validate::ON_FAIL ||= sub { require Carp; Carp::croak( $_[0] ) }; + + $Params::Validate::ON_FAIL->($Params::Validate::ERROR) + } +} + +sub validate_pos (\@@) +{ + local $Params::Validate::ERROR; + local $Params::Validate::ON_FAIL; + local $Params::Validate::CALLER = caller; + + my $r; + if (defined wantarray) + { + $r = &_validate_pos; + } + else + { + &_validate_pos; + } + + check_for_error(); + + return wantarray ? @$r : $r if defined wantarray; +} + +sub validate (\@$) +{ + local $Params::Validate::ERROR; + local $Params::Validate::ON_FAIL; + local $Params::Validate::CALLER = caller; + + my $r; + if (defined wantarray) + { + $r = &_validate; + } + else + { + &_validate; + } + + check_for_error(); + + return wantarray ? %$r : $r if defined wantarray; +} + +sub validate_with +{ + local $Params::Validate::ERROR; + local $Params::Validate::ON_FAIL; + local $Params::Validate::CALLER = caller; + + my $r; + if (defined wantarray) + { + $r = &_validate_with; + } + else + { + &_validate_with; + } + + check_for_error(); + + my %p = @_; + if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) + { + return wantarray ? @$r : $r if defined wantarray; + } + else + { + return wantarray ? %$r : $r if defined wantarray; + } +} +EOF + + die $@ if $@; + } + else + { + *validate = \&_validate; + *validate_pos = \&_validate_pos; + *validate_with = \&_validate_with; + } +} + +1; + +__END__ + +=head1 NAME + +Params::ValidateXS - XS implementation of Params::Validate + +=head1 SYNOPSIS + + See Params::Validate + +=head1 DESCRIPTION + +This is an XS implementation of Params::Validate. See the +Params::Validate documentation for details. + +=head1 COPYRIGHT + +Copyright (c) 2004 David Rolsky. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/Params/Validate.pm =================================================================== --- /branches/mt4.11/extlib/Params/Validate.pm (revision 1098) +++ /branches/mt4.11/extlib/Params/Validate.pm (revision 1098) @@ -0,0 +1,724 @@ +# Copyright (c) 2000-2004 Dave Rolsky +# All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. See the LICENSE +# file that comes with this distribution for more details. + +package Params::Validate; + +use strict; + +BEGIN +{ + use Exporter; + use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %OPTIONS $options $NO_VALIDATION ); + + @ISA = 'Exporter'; + + $VERSION = '0.73'; + + my %tags = + ( types => + [ qw( SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF + SCALARREF HANDLE BOOLEAN UNDEF OBJECT ) ], + ); + + %EXPORT_TAGS = + ( 'all' => [ qw( validate validate_pos validation_options validate_with ), + map { @{ $tags{$_} } } keys %tags ], + %tags, + ); + + @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'set_options' ); + @EXPORT = qw( validate validate_pos ); + + $NO_VALIDATION = $ENV{PERL_NO_VALIDATION}; + + eval { require Params::ValidateXS; } unless $ENV{PV_TEST_PERL}; + + if ( $@ || $ENV{PV_TEST_PERL} ) + { + # suppress subroutine redefined warnings + local $^W = 0; + require Params::ValidatePP; + } +} + + +1; + +__END__ + +=head1 NAME + +Params::Validate - Validate method/function parameters + +=head1 SYNOPSIS + + use Params::Validate qw(:all); + + # takes named params (hash or hashref) + sub foo + { + validate( @_, { foo => 1, # mandatory + bar => 0, # optional + } + ); + } + + # takes positional params + sub bar + { + # first two are mandatory, third is optional + validate_pos( @_, 1, 1, 0 ); + } + + + sub foo2 + { + validate( @_, + { foo => + # specify a type + { type => ARRAYREF }, + + bar => + # specify an interface + { can => [ 'print', 'flush', 'frobnicate' ] }, + + baz => + { type => SCALAR, # a scalar ... + # ... that is a plain integer ... + regex => qr/^\d+$/, + callbacks => + { # ... and smaller than 90 + 'less than 90' => sub { shift() < 90 }, + }, + } + } + ); + } + + sub with_defaults + { + my %p = validate( @_, { foo => 1, # required + # $p{bar} will be 99 if bar is not + # given. bar is now optional. + bar => { default => 99 } } ); + } + + sub pos_with_defaults + { + my @p = validate_pos( @_, 1, { default => 99 } ); + } + + sub sets_options_on_call + { + my %p = validate_with + ( params => \@_, + spec => { foo => { type SCALAR, default => 2 } }, + normalize_keys => sub { $_[0] =~ s/^-//; lc $_[0] }, + ); + } + +=head1 DESCRIPTION + +The Params::Validate module allows you to validate method or function +call parameters to an arbitrary level of specificity. At the simplest +level, it is capable of validating the required parameters were given +and that no unspecified additional parameters were passed in. + +It is also capable of determining that a parameter is of a specific +type, that it is an object of a certain class hierarchy, that it +possesses certain methods, or applying validation callbacks to +arguments. + +=head2 EXPORT + +The module always exports the C and C +functions. + +It also has an additional function available for export, +C, which can be used to validate any type of +parameters, and set various options on a per-invocation basis. + +In addition, it can export the following constants, which are used as +part of the type checking. These are C, C, +C, C, C, C, and C, +C, C, C, and C. These are explained +in the section on L. + +The constants are available via the export tag C<:types>. There is +also an C<:all> tag which includes all of the constants as well as the +C function. + +=head1 PARAMETER VALIDATION + +The validation mechanisms provided by this module can handle both +named or positional parameters. For the most part, the same features +are available for each. The biggest difference is the way that the +validation specification is given to the relevant subroutine. The +other difference is in the error messages produced when validation +checks fail. + +When handling named parameters, the module is capable of handling +either a hash or a hash reference transparently. + +Subroutines expecting named parameters should call the C +subroutine like this: + + validate( @_, { parameter1 => validation spec, + parameter2 => validation spec, + ... + } ); + +Subroutines expecting positional parameters should call the +C subroutine like this: + + validate_pos( @_, { validation spec }, { validation spec } ); + +=head2 Mandatory/Optional Parameters + +If you just want to specify that some parameters are mandatory and +others are optional, this can be done very simply. + +For a subroutine expecting named parameters, you would do this: + + validate( @_, { foo => 1, bar => 1, baz => 0 } ); + +This says that the "foo" and "bar" parameters are mandatory and that +the "baz" parameter is optional. The presence of any other +parameters will cause an error. + +For a subroutine expecting positional parameters, you would do this: + + validate_pos( @_, 1, 1, 0, 0 ); + +This says that you expect at least 2 and no more than 4 parameters. +If you have a subroutine that has a minimum number of parameters but +can take any maximum number, you can do this: + + validate_pos( @_, 1, 1, (0) x (@_ - 2) ); + +This will always be valid as long as at least two parameters are +given. A similar construct could be used for the more complex +validation parameters described further on. + +Please note that this: + + validate_pos( @_, 1, 1, 0, 1, 1 ); + +makes absolutely no sense, so don't do it. Any zeros must come at the +end of the validation specification. + +In addition, if you specify that a parameter can have a default, then +it is considered optional. + +=head2 Type Validation + +This module supports the following simple types, which can be +L: + +=over 4 + +=item * SCALAR + +A scalar which is not a reference, such as C<10> or C<'hello'>. A +parameter that is undefined is B treated as a scalar. If you +want to allow undefined values, you will have to specify C. + +=item * ARRAYREF + +An array reference such as C<[1, 2, 3]> or C<\@foo>. + +=item * HASHREF + +A hash reference such as C<{ a => 1, b => 2 }> or C<\%bar>. + +=item * CODEREF + +A subroutine reference such as C<\&foo_sub> or C. + +=item * GLOB + +This one is a bit tricky. A glob would be something like C<*FOO>, but +not C<\*FOO>, which is a glob reference. It should be noted that this +trick: + + my $fh = do { local *FH; }; + +makes C<$fh> a glob, not a glob reference. On the other hand, the +return value from C is a glob reference. Either can +be used as a file or directory handle. + +=item * GLOBREF + +A glob reference such as C<\*FOO>. See the L entry above +for more details. + +=item * SCALARREF + +A reference to a scalar such as C<\$x>. + +=item * UNDEF + +An undefined value + +=item * OBJECT + +A blessed reference. + +=item * BOOLEAN + +This is a special option, and is just a shortcut for C. + +=item * HANDLE + +This option is also special, and is just a shortcut for C. However, it seems likely that most people interested in +either globs or glob references are likely to really be interested in +whether the parameter in questoin could be a valid file or directory +handle. + +=back + +To specify that a parameter must be of a given type when using named +parameters, do this: + + validate( @_, { foo => { type => SCALAR }, + bar => { type => HASHREF } } ); + +If a parameter can be of more than one type, just use the bitwise or +(C<|>) operator to combine them. + + validate( @_, { foo => { type => GLOB | GLOBREF } ); + +For positional parameters, this can be specified as follows: + + validate_pos( @_, { type => SCALAR | ARRAYREF }, { type => CODEREF } ); + +=head2 Interface Validation + +To specify that a parameter is expected to have a certain set of +methods, we can do the following: + + validate( @_, + { foo => + # just has to be able to ->bar + { can => 'bar' } } ); + + ... or ... + + validate( @_, + { foo => + # must be able to ->bar and ->print + { can => [ qw( bar print ) ] } } ); + +=head2 Class Validation + +A word of warning. When constructing your external interfaces, it is +probably better to specify what methods you expect an object to +have rather than what class it should be of (or a child of). This +will make your API much more flexible. + +With that said, if you want to validate that an incoming parameter +belongs to a class (or child class) or classes, do: + + validate( @_, + { foo => + { isa => 'My::Frobnicator' } } ); + + ... or ... + + validate( @_, + { foo => + { isa => [ qw( My::Frobnicator IO::Handle ) ] } } ); + # must be both, not either! + +=head2 Regex Validation + +If you want to specify that a given parameter must match a specific +regular expression, this can be done with "regex" spec key. For +example: + + + validate( @_, + { foo => + { regex => qr/^\d+$/ } } ); + +The value of the "regex" key may be either a string or a pre-compiled +regex created via C. + +The C module on CPAN is an excellent source of regular +expressions suitable for validating input. + +=head2 Callback Validation + +If none of the above are enough, it is possible to pass in one or more +callbacks to validate the parameter. The callback will be given the +B of the parameter as its first argument. Its second argument +will be all the parameters, as a reference to either a hash or array. +Callbacks are specified as hash reference. The key is an id for the +callback (used in error messages) and the value is a subroutine +reference, such as: + + validate( @_, + { foo => + callbacks => + { 'smaller than a breadbox' => sub { shift() < $breadbox }, + 'green or blue' => + sub { $_[0] eq 'green' || $_[0] eq 'blue' } } } ); + + validate( @_, + { foo => + callbacks => + { 'bigger than baz' => sub { $_[0] > $_[1]->{baz} } } } ); + +=head2 Untainting + +If you want values untainted, set the "untaint" key in a spec hashref +to a true value, like this: + + my %p = + validate( @_, { foo => + { type => SCALAR, untaint => 1 }, + bar => + { type => ARRAYREF } } ); + +This will untaint the "foo" parameter if the parameters are valid. + +Note that untainting is only done if I are valid. +Also, only the return values are untainted, not the original values +passed into the validation function. + +Asking for untainting of a reference value will not do anything, as +C will only attempt to untaint the reference itself. + +=head2 Mandatory/Optional Revisited + +If you want to specify something such as type or interface, plus the +fact that a parameter can be optional, do this: + + validate( @_, { foo => + { type => SCALAR }, + bar => + { type => ARRAYREF, optional => 1 } } ); + +or this for positional parameters: + + validate_pos( @_, { type => SCALAR }, { type => ARRAYREF, optional => 1 } ); + +By default, parameters are assumed to be mandatory unless specified as +optional. + +=head2 Dependencies + +It also possible to specify that a given optional parameter depends on +the presence of one or more other optional parameters. + + validate( @_, { cc_number => + { type => SCALAR, optional => 1, + depends => [ 'cc_expiration', 'cc_holder_name' ], + }, + cc_expiration + { type => SCALAR, optional => 1 }, + cc_holder_name + { type => SCALAR, optional => 1 }, + } ); + +In this case, "cc_number", "cc_expiration", and "cc_holder_name" are +all optional. However, if "cc_number" is provided, then +"cc_expiration" and "cc_holder_name" must be provided as well. + +This allows you to group together sets of parameters that all must be +provided together. + +The C version of dependencies is slightly different, +in that you can only depend on one other parameter. Also, if for +example, the second parameter 2 depends on the fourth parameter, then +it implies a dependency on the third parameter as well. This is +because if the fourth parameter is required, then the user must also +provide a third parameter so that there can be four parameters in +total. + +C will die if you try to depend on a parameter not +declared as part of your parameter specification. + +=head2 Specifying defaults + +If the C or C functions are called in a +list context, they will return an array or hash containing the +original parameters plus defaults as indicated by the validation spec. + +If the function is not called in a list context, providing a default +in the validation spec still indicates that the parameter is optional. + +The hash or array returned from the function will always be a copy of +the original parameters, in order to leave C<@_> untouched for the +calling function. + +Simple examples of defaults would be: + + my %p = validate( @_, { foo => 1, bar => { default => 99 } } ); + + my @p = validate( @_, 1, { default => 99 } ); + +In scalar context, a hash reference or array reference will be +returned, as appropriate. + +=head1 USAGE NOTES + +=head2 Validation failure + +By default, when validation fails C calls +C. This can be overridden by setting the C +option, which is described in the L<"GLOBAL" OPTIONS|"GLOBAL" OPTIONS> +section. + +=head2 Method calls + +When using this module to validate the parameters passed to a method +call, you will probably want to remove the class/object from the +parameter list B calling C or C. +If your method expects named parameters, then this is necessary for +the C function to actually work, otherwise C<@_> will not +be useable as a hash, because it will first have your object (or +class) B by a set of keys and values. + +Thus the idiomatic usage of C in a method call will look +something like this: + + sub method + { + my $self = shift; + + my %params = validate( @_, { foo => 1, bar => { type => ARRAYREF } } ); + } + +=head1 "GLOBAL" OPTIONS + +Because the calling syntax for the C and C +functions does not make it possible to specify any options other than +the the validation spec, it is possible to set some options as +pseudo-'globals'. These allow you to specify such things as whether +or not the validation of named parameters should be case sensitive, +for one example. + +These options are called pseudo-'globals' because these settings are +B. + +In other words, if I am in package C and I call +C, those options are only in +effect when I call C from package C. + +While this is quite different from how most other modules operate, I +feel that this is necessary in able to make it possible for one +module/application to use Params::Validate while still using other +modules that also use Params::Validate, perhaps with different +options set. + +The downside to this is that if you are writing an app with a standard +calling style for all functions, and your app has ten modules, B>. + +=head2 Options + +=over 4 + +=item * normalize_keys => $callback + +This option is only relevant when dealing with named parameters. + +This callback will be used to transform the hash keys of both the +parameters and the parameter spec when C or +C are called. + +Any alterations made by this callback will be reflected in the +parameter hash that is returned by the validation function. For +example: + + sub foo { + return + validate_with( params => \@_, + spec => { foo => { type => SCALAR } }, + normalize_keys => + sub { my $k = shift; $k =~ s/^-//; return uc $k }, + ); + + } + + %p = foo( foo => 20 ); + + # $p{FOO} is now 20 + + %p = foo( -fOo => 50 ); + + # $p{FOO} is now 50 + +The callback must return a defined value. + +If a callback is given than the deprecated "ignore_case" and +"strip_leading" options are ignored. + +=item * allow_extra => $boolean + +If true, then the validation routine will allow extra parameters not +named in the validation specification. In the case of positional +parameters, this allows an unlimited number of maximum parameters +(though a minimum may still be set). Defaults to false. + +=item * on_fail => $callback + +If given, this callback will be called whenever a validation check +fails. It will be called with a single parameter, which will be a +string describing the failure. This is useful if you wish to have +this module throw exceptions as objects rather than as strings, for +example. + +This callback is expected to C internally. If it does not, the +validation will proceed onwards, with unpredictable results. + +The default is to simply use the Carp module's C function. + +=item * stack_skip => $number + +This tells Params::Validate how many stack frames to skip when finding +a subroutine name to use in error messages. By default, it looks one +frame back, at the immediate caller to C or +C. If this option is set, then the given number of +frames are skipped instead. + +=item * ignore_case => $boolean + +DEPRECATED + +This is only relevant when dealing with named parameters. If it is +true, then the validation code will ignore the case of parameter +names. Defaults to false. + +=item * strip_leading => $characters + +DEPRECATED + +This too is only relevant when dealing with named parameters. If this +is given then any parameters starting with these characters will be +considered equivalent to parameters without them entirely. For +example, if this is specified as '-', then C<-foo> and C would be +considered identical. + +=back + +=head1 PER-INVOCATION OPTIONS + +The C function can be used to set the options listed +above on a per-invocation basis. For example: + + my %p = + validate_with + ( params => \@_, + spec => { foo => { type => SCALAR }, + bar => { default => 10 } }, + allow_extra => 1, + ); + +In addition to the options listed above, it is also possible to set +the option "called", which should be a string. This string will be +used in any error messages caused by a failure to meet the validation +spec. + +This subroutine will validate named parameters as a hash if the "spec" +parameter is a hash reference. If it is an array reference, the +parameters are assumed to be positional. + + my %p = + validate_with + ( params => \@_, + spec => { foo => { type => SCALAR }, + bar => { default => 10 } }, + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + + my @p = + validate_with + ( params => \@_, + spec => [ { type => SCALAR }, + { default => 10 } ], + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + +=head1 DISABLING VALIDATION + +If the environment variable C is set to something +true, then validation is turned off. This may be useful if you only +want to use this module during development but don't want the speed +hit during production. + +The only error that will be caught will be when an odd number of +parameters are passed into a function/method that expects a hash. + +If you want to selectively turn validation on and off at runtime, you +can directly set the C<$Params::Validate::NO_VALIDATION> global +variable. It is B recommended that you B any +changes to this variable, because other modules you are using may +expect validation to be on when they execute. For example: + + + { + local $Params::Validate::NO_VALIDATION = 1; + # no error + foo( bar => 2 ); + } + + # error + foo( bar => 2 ); + + sub foo + { + my %p = validate( @_, { foo => 1 } ); + ... + } + +But if you want to shoot yourself in the foot and just turn it off, go +ahead! + +=head1 LIMITATIONS + +Right now there is no way (short of a callback) to specify that +something must be of one of a list of classes, or that it must possess +one of a list of methods. If this is desired, it can be added in the +future. + +Ideally, there would be only one validation function. If someone +figures out how to do this, please let me know. + +=head1 SUPPORT + +For now, support questions should be sent to Dave at autarch@urth.org. +The CVS repository is on Savannah at +https://savannah.nongnu.org/projects/p-v-perl/. + +=head1 SEE ALSO + +Getargs::Long - similar capabilities with a different interface. If +you like what Params::Validate does but not its 'feel' try this one +instead. + +Carp::Assert and Class::Contract - other modules in the general spirit +of validating that certain things are true before/while/after +executing actual program code. + +=head1 AUTHORS + +Dave Rolsky, and Ilya Martynov + +=head1 COPYRIGHT + +Copyright (c) 2004 David Rolsky. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/Params/ValidatePP.pm =================================================================== --- /branches/mt4.11/extlib/Params/ValidatePP.pm (revision 1098) +++ /branches/mt4.11/extlib/Params/ValidatePP.pm (revision 1098) @@ -0,0 +1,700 @@ +# Copyright (c) 2000-2004 Dave Rolsky +# All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. See the LICENSE +# file that comes with this distribution for more details. + +package Params::Validate; + +use strict; + +BEGIN +{ + sub SCALAR () { 1 } + sub ARRAYREF () { 2 } + sub HASHREF () { 4 } + sub CODEREF () { 8 } + sub GLOB () { 16 } + sub GLOBREF () { 32 } + sub SCALARREF () { 64 } + sub UNKNOWN () { 128 } + sub UNDEF () { 256 } + sub OBJECT () { 512 } + + sub HANDLE () { 16 | 32 } + sub BOOLEAN () { 1 | 256 } +} + +# Various internals notes (for me and any future readers of this +# monstrosity): +# +# - A lot of the weirdness is _intentional_, because it optimizes for +# the _success_ case. It does not really matter how slow the code is +# after it enters a path that leads to reporting failure. But the +# "success" path should be as fast as possible. +# +# -- We only calculate $called as needed for this reason, even though it +# means copying code all over. +# +# - All the validation routines need to be careful never to alter the +# references that are passed. +# +# -- The code assumes that _most_ callers will not be using the +# skip_leading or ignore_case features. In order to not alter the +# references passed in, we copy them wholesale when normalizing them +# to make these features work. This is slower but lets us be faster +# when not using them. + + +# Matt Sergeant came up with this prototype, which slickly takes the +# first array (which should be the caller's @_), and makes it a +# reference. Everything after is the parameters for validation. +sub validate_pos (\@@) +{ + return if $NO_VALIDATION && ! defined wantarray; + + my $p = shift; + + my @specs = @_; + + my @p = @$p; + if ( $NO_VALIDATION ) + { + # if the spec is bigger that's where we can start adding + # defaults + for ( my $x = $#p + 1; $x <= $#specs; $x++ ) + { + $p[$x] = + $specs[$x]->{default} + if ref $specs[$x] && exists $specs[$x]->{default}; + } + + return wantarray ? @p : \@p; + } + + # I'm too lazy to pass these around all over the place. + local $options ||= _get_options( (caller(0))[0] ) + unless defined $options; + + my $min = 0; + + while (1) + { + last unless ( ref $specs[$min] ? + ! ( exists $specs[$min]->{default} || $specs[$min]->{optional} ) : + $specs[$min] ); + + $min++; + } + + my $max = scalar @specs; + + my $actual = scalar @p; + unless ($actual >= $min && ( $options->{allow_extra} || $actual <= $max ) ) + { + my $minmax = + ( $options->{allow_extra} ? + "at least $min" : + ( $min != $max ? "$min - $max" : $max ) ); + + my $val = $options->{allow_extra} ? $min : $max; + $minmax .= $val != 1 ? ' were' : ' was'; + + my $called = _get_called(); + + $options->{on_fail}-> + ( "$actual parameter" . + ($actual != 1 ? 's' : '') . + " " . + ($actual != 1 ? 'were' : 'was' ) . + " passed to $called but $minmax expected\n" ); + } + + my $bigger = $#p > $#specs ? $#p : $#specs; + foreach ( 0..$bigger ) + { + my $spec = $specs[$_]; + + next unless ref $spec; + + if ( $_ <= $#p ) + { + my $value = defined $p[$_] ? qq|"$p[$_]"| : 'undef'; + _validate_one_param( $p[$_], \@p, $spec, "Parameter #" . ($_ + 1) . " ($value)"); + } + + $p[$_] = $spec->{default} if $_ > $#p && exists $spec->{default}; + } + + _validate_pos_depends(\@p, \@specs); + + foreach ( grep { defined $p[$_] && ! ref $p[$_] + && ref $specs[$_] && $specs[$_]{untaint} } + 0..$bigger ) + { + ($p[$_]) = $p[$_] =~ /(.+)/; + } + + return wantarray ? @p : \@p; +} + +sub _validate_pos_depends +{ + my ( $p, $specs ) = @_; + + for my $p_idx ( 0..$#$p ) + { + my $spec = $specs->[$p_idx]; + + next unless $spec && UNIVERSAL::isa( $spec, 'HASH' ) && exists $spec->{depends}; + + my $depends = $spec->{depends}; + + if ( ref $depends ) + { + require Carp; + local $Carp::CarpLevel = 2; + Carp::croak( "Arguments to 'depends' for validate_pos() must be a scalar" ) + } + + my $p_size = scalar @$p; + if ( $p_size < $depends - 1 ) + { + my $error = ( "Parameter #" . ($p_idx + 1) . " depends on parameter #" . + $depends . ", which was not given" ); + + $options->{on_fail}->($error); + } + } + return 1; +} + +sub _validate_named_depends +{ + my ( $p, $specs ) = @_; + + foreach my $pname ( keys %$p ) + { + my $spec = $specs->{$pname}; + + next unless $spec && UNIVERSAL::isa( $spec, 'HASH' ) && $spec->{depends}; + + unless ( UNIVERSAL::isa( $spec->{depends}, 'ARRAY' ) || ! ref $spec->{depends} ) + { + require Carp; + local $Carp::CarpLevel = 2; + Carp::croak( "Arguments to 'depends' must be a scalar or arrayref" ); + } + + foreach my $depends_name ( ref $spec->{depends} + ? @{ $spec->{depends} } + : $spec->{depends} ) + { + unless ( exists $p->{$depends_name} ) + { + my $error = ( "Parameter '$pname' depends on parameter '" . + $depends_name . "', which was not given" ); + + $options->{on_fail}->($error); + } + } + } +} + +sub validate (\@$) +{ + return if $NO_VALIDATION && ! defined wantarray; + + my $p = $_[0]; + + my $specs = $_[1]; + local $options = _get_options( (caller(0))[0] ) unless defined $options; + + unless ( $NO_VALIDATION ) + { + if ( ref $p eq 'ARRAY' ) + { + # we were called as validate( @_, ... ) where @_ has a + # single element, a hash reference + if ( ref $p->[0] ) + { + $p = $p->[0]; + } + elsif ( @$p % 2 ) + { + my $called = _get_called(); + + $options->{on_fail}-> + ( "Odd number of parameters in call to $called " . + "when named parameters were expected\n" ); + } + else + { + $p = {@$p}; + } + } + } + + if ( $options->{normalize_keys} ) + { + $specs = _normalize_callback( $specs, $options->{normalize_keys} ); + $p = _normalize_callback( $p, $options->{normalize_keys} ); + } + elsif ( $options->{ignore_case} || $options->{strip_leading} ) + { + $specs = _normalize_named($specs); + $p = _normalize_named($p); + } + + if ($NO_VALIDATION) + { + return + ( wantarray ? + ( + # this is a hash containing just the defaults + ( map { $_ => $specs->{$_}->{default} } + grep { ref $specs->{$_} && exists $specs->{$_}->{default} } + keys %$specs + ), + ( ref $p eq 'ARRAY' ? + ( ref $p->[0] ? + %{ $p->[0] } : + @$p ) : + %$p + ) + ) : + do + { + my $ref = + ( ref $p eq 'ARRAY' ? + ( ref $p->[0] ? + $p->[0] : + {@$p} ) : + $p + ); + + foreach ( grep { ref $specs->{$_} && exists $specs->{$_}->{default} } + keys %$specs ) + { + $ref->{$_} = $specs->{$_}->{default} + unless exists $ref->{$_}; + } + + return $ref; + } + ); + } + + _validate_named_depends($p, $specs); + + unless ( $options->{allow_extra} ) + { + my $called = _get_called(); + + if ( my @unmentioned = grep { ! exists $specs->{$_} } keys %$p ) + { + $options->{on_fail}-> + ( "The following parameter" . (@unmentioned > 1 ? 's were' : ' was') . + " passed in the call to $called but " . + (@unmentioned > 1 ? 'were' : 'was') . + " not listed in the validation options: @unmentioned\n" ); + } + } + + my @missing; + + # the iterator needs to be reset in case the same hashref is being + # passed to validate() on successive calls, because we may not go + # through all the hash's elements + keys %$specs; + OUTER: + while ( my ($key, $spec) = each %$specs ) + { + if ( ! exists $p->{$key} && + ( ref $spec + ? ! ( + do + { + # we want to short circuit the loop here if we + # can assign a default, because there's no need + # check anything else at all. + if ( exists $spec->{default} ) + { + $p->{$key} = $spec->{default}; + next OUTER; + } + } + || + do + { + # Similarly, an optional parameter that is + # missing needs no additional processing. + next OUTER if $spec->{optional}; + } + ) + : $spec + ) + ) + { + push @missing, $key; + } + # Can't validate a non hashref spec beyond the presence or + # absence of the parameter. + elsif (ref $spec) + { + my $value = defined $p->{$key} ? qq|"$p->{$key}"| : 'undef'; + _validate_one_param( $p->{$key}, $p, $spec, "The '$key' parameter ($value)" ); + } + } + + if (@missing) + { + my $called = _get_called(); + + my $missing = join ', ', map {"'$_'"} @missing; + $options->{on_fail}-> + ( "Mandatory parameter" . + (@missing > 1 ? 's': '') . + " $missing missing in call to $called\n" ); + } + + # do untainting after we know everything passed + foreach my $key ( grep { defined $p->{$_} && ! ref $p->{$_} + && ref $specs->{$_} && $specs->{$_}{untaint} } + keys %$p ) + { + ($p->{$key}) = $p->{$key} =~ /(.+)/; + } + + return wantarray ? %$p : $p; +} + +sub validate_with +{ + return if $NO_VALIDATION && ! defined wantarray; + + my %p = @_; + + local $options = _get_options( (caller(0))[0], %p ); + + unless ( $NO_VALIDATION ) + { + unless ( exists $options->{called} ) + { + $options->{called} = (caller( $options->{stack_skip} ))[3]; + } + + } + + if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) + { + return validate_pos( @{ $p{params} }, @{ $p{spec} } ); + } + else + { + # intentionally ignore the prototype because this contains + # either an array or hash reference, and validate() will + # handle either one properly + return &validate( $p{params}, $p{spec} ); + } +} + +sub _normalize_callback +{ + my ( $p, $func ) = @_; + + my %new; + + foreach my $key ( keys %$p ) + { + my $new_key = $func->( $key ); + + unless ( defined $new_key ) + { + die "The normalize_keys callback did not return a defined value when normalizing the key '$key'"; + } + + if ( exists $new{$new_key} ) + { + die "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'"; + } + + $new{$new_key} = $p->{ $key }; + } + + return \%new; +} + +sub _normalize_named +{ + # intentional copy so we don't destroy original + my %h = %{ $_[0] }; + + if ( $options->{ignore_case} ) + { + $h{ lc $_ } = delete $h{$_} for keys %h; + } + + if ( $options->{strip_leading} ) + { + foreach my $key (keys %h) + { + my $new; + ($new = $key) =~ s/^\Q$options->{strip_leading}\E//; + $h{$new} = delete $h{$key}; + } + } + + return \%h; +} + +sub _validate_one_param +{ + my ($value, $params, $spec, $id) = @_; + + if ( exists $spec->{type} ) + { + unless ( _get_type($value) & $spec->{type} ) + { + my $type = _get_type($value); + + my @is = _typemask_to_strings($type); + my @allowed = _typemask_to_strings($spec->{type}); + my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a'; + + my $called = _get_called(1); + + $options->{on_fail}-> + ( "$id to $called was $article '@is', which " . + "is not one of the allowed types: @allowed\n" ); + } + } + + # short-circuit for common case + return unless ( $spec->{isa} || $spec->{can} || + $spec->{callbacks} || $spec->{regex} ); + + if ( exists $spec->{isa} ) + { + foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} ) + { + unless ( UNIVERSAL::isa( $value, $_ ) ) + { + my $is = ref $value ? ref $value : 'plain scalar'; + my $article1 = $_ =~ /^[aeiou]/i ? 'an' : 'a'; + my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a'; + + my $called = _get_called(1); + + $options->{on_fail}-> + ( "$id to $called was not $article1 '$_' " . + "(it is $article2 $is)\n" ); + } + } + } + + if ( exists $spec->{can} ) + { + foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} ) + { + unless ( UNIVERSAL::can( $value, $_ ) ) + { + my $called = _get_called(1); + + $options->{on_fail}->( "$id to $called does not have the method: '$_'\n" ); + } + } + } + + if ( $spec->{callbacks} ) + { + unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) ) + { + my $called = _get_called(1); + + $options->{on_fail}-> + ( "'callbacks' validation parameter for $called must be a hash reference\n" ); + } + + + foreach ( keys %{ $spec->{callbacks} } ) + { + unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) ) + { + my $called = _get_called(1); + + $options->{on_fail}->( "callback '$_' for $called is not a subroutine reference\n" ); + } + + unless ( $spec->{callbacks}{$_}->($value, $params) ) + { + my $called = _get_called(1); + + $options->{on_fail}->( "$id to $called did not pass the '$_' callback\n" ); + } + } + } + + if ( exists $spec->{regex} ) + { + unless ( $value =~ /$spec->{regex}/ ) + { + my $called = _get_called(1); + + $options->{on_fail}->( "$id to $called did not pass regex check\n" ); + } + } +} + +{ + # if it UNIVERSAL::isa the string on the left then its the type on + # the right + my %isas = ( 'ARRAY' => ARRAYREF, + 'HASH' => HASHREF, + 'CODE' => CODEREF, + 'GLOB' => GLOBREF, + 'SCALAR' => SCALARREF, + ); + my %simple_refs = map { $_ => 1 } keys %isas; + + sub _get_type + { + return UNDEF unless defined $_[0]; + + my $ref = ref $_[0]; + unless ($ref) + { + # catches things like: my $fh = do { local *FH; }; + return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' ); + return SCALAR; + } + + return $isas{$ref} if $simple_refs{$ref}; + + foreach ( keys %isas ) + { + return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ ); + } + + # I really hope this never happens. + return UNKNOWN; + } +} + +{ + my %type_to_string = ( SCALAR() => 'scalar', + ARRAYREF() => 'arrayref', + HASHREF() => 'hashref', + CODEREF() => 'coderef', + GLOB() => 'glob', + GLOBREF() => 'globref', + SCALARREF() => 'scalarref', + UNDEF() => 'undef', + OBJECT() => 'object', + UNKNOWN() => 'unknown', + ); + + sub _typemask_to_strings + { + my $mask = shift; + + my @types; + foreach ( SCALAR, ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF, + SCALARREF, UNDEF, OBJECT, UNKNOWN ) + { + push @types, $type_to_string{$_} if $mask & $_; + } + return @types ? @types : ('unknown'); + } +} + +{ + my %defaults = ( ignore_case => 0, + strip_leading => 0, + allow_extra => 0, + on_fail => sub { require Carp; + Carp::confess($_[0]) }, + stack_skip => 1, + normalize_keys => undef, + ); + + *set_options = \&validation_options; + sub validation_options + { + my %opts = @_; + + my $caller = caller; + + foreach ( keys %defaults ) + { + $opts{$_} = $defaults{$_} unless exists $opts{$_}; + } + + $OPTIONS{$caller} = \%opts; + } + + sub _get_options + { + my ( $caller, %override ) = @_; + + if ( %override ) + { + return + ( $OPTIONS{$caller} ? + { %{ $OPTIONS{$caller} }, + %override } : + { %defaults, %override } + ); + } + else + { + return + ( exists $OPTIONS{$caller} ? + $OPTIONS{$caller} : + \%defaults ); + } + } +} + +sub _get_called +{ + my $extra_skip = $_[0] || 0; + + # always add one more for this sub + $extra_skip++; + + my $called = + ( exists $options->{called} ? + $options->{called} : + ( caller( $options->{stack_skip} + $extra_skip ) )[3] + ); + + $called = 'N/A' unless defined $called; + + return $called; +} + +1; + +__END__ + +=head1 NAME + +Params::ValidatePP - pure Perl implementation of Params::Validate + +=head1 SYNOPSIS + + See Params::Validate + +=head1 DESCRIPTION + +This is a pure Perl implementation of Params::Validate. See the +Params::Validate documentation for details. + +=head1 COPYRIGHT + +Copyright (c) 2004 David Rolsky. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut Index: /branches/mt4.11/extlib/Params/Check.pm =================================================================== --- /branches/mt4.11/extlib/Params/Check.pm (revision 1098) +++ /branches/mt4.11/extlib/Params/Check.pm (revision 1098) @@ -0,0 +1,678 @@ +package Params::Check; + +use strict; + +use Carp qw[carp croak]; +use Locale::Maketext::Simple Style => 'gettext'; + +use Data::Dumper; + +BEGIN { + use Exporter (); + use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN + $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES + $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL + $SANITY_CHECK_TEMPLATE + ]; + + @ISA = qw[ Exporter ]; + @EXPORT_OK = qw[check allow last_error]; + + $VERSION = '0.24'; + $VERBOSE = $^W ? 1 : 0; + $NO_DUPLICATES = 0; + $STRIP_LEADING_DASHES = 0; + $STRICT_TYPE = 0; + $ALLOW_UNKNOWN = 0; + $PRESERVE_CASE = 0; + $ONLY_ALLOW_DEFINED = 0; + $SANITY_CHECK_TEMPLATE = 1; + $WARNINGS_FATAL = 0; +} + +my %known_keys = map { $_ => 1 } + qw| required allow default strict_type no_override + store defined |; + +=pod + +=head1 NAME + +Params::Check -- A generic input parsing/checking mechanism. + +=head1 SYNOPSIS + + use Params::Check qw[check allow last_error]; + + sub fill_personal_info { + my %hash = @_; + my $x; + + my $tmpl = { + firstname => { required => 1, defined => 1 }, + lastname => { required => 1, store => \$x }, + gender => { required => 1, + allow => [qr/M/i, qr/F/i], + }, + married => { allow => [0,1] }, + age => { default => 21, + allow => qr/^\d+$/, + }, + + phone => { allow => [ sub { return 1 if /$valid_re/ }, + '1-800-PERL' ] + }, + id_list => { default => [], + strict_type => 1 + }, + employer => { default => 'NSA', no_override => 1 }, + }; + + ### check() returns a hashref of parsed args on success ### + my $parsed_args = check( $tmpl, \%hash, $VERBOSE ) + or die qw[Could not parse arguments!]; + + ... other code here ... + } + + my $ok = allow( $colour, [qw|blue green yellow|] ); + + my $error = Params::Check::last_error(); + + +=head1 DESCRIPTION + +Params::Check is a generic input parsing/checking mechanism. + +It allows you to validate input via a template. The only requirement +is that the arguments must be named. + +Params::Check can do the following things for you: + +=over 4 + +=item * + +Convert all keys to lowercase + +=item * + +Check if all required arguments have been provided + +=item * + +Set arguments that have not been provided to the default + +=item * + +Weed out arguments that are not supported and warn about them to the +user + +=item * + +Validate the arguments given by the user based on strings, regexes, +lists or even subroutines + +=item * + +Enforce type integrity if required + +=back + +Most of Params::Check's power comes from its template, which we'll +discuss below: + +=head1 Template + +As you can see in the synopsis, based on your template, the arguments +provided will be validated. + +The template can take a different set of rules per key that is used. + +The following rules are available: + +=over 4 + +=item default + +This is the default value if none was provided by the user. +This is also the type C will look at when checking type +integrity (see below). + +=item required + +A boolean flag that indicates if this argument was a required +argument. If marked as required and not provided, check() will fail. + +=item strict_type + +This does a C check on the argument provided. The C of the +argument must be the same as the C of the default value for this +check to pass. + +This is very useful if you insist on taking an array reference as +argument for example. + +=item defined + +If this template key is true, enforces that if this key is provided by +user input, its value is C. This just means that the user is +not allowed to pass C as a value for this key and is equivalent +to: + allow => sub { defined $_[0] && OTHER TESTS } + +=item no_override + +This allows you to specify C in your template. ie, they +keys that are not allowed to be altered by the user. It pretty much +allows you to keep all your C data in one place; the +C template. + +=item store + +This allows you to pass a reference to a scalar, in which the data +will be stored: + + my $x; + my $args = check(foo => { default => 1, store => \$x }, $input); + +This is basically shorthand for saying: + + my $args = check( { foo => { default => 1 }, $input ); + my $x = $args->{foo}; + +You can alter the global variable $Params::Check::NO_DUPLICATES to +control whether the C'd key will still be present in your +result set. See the L section below. + +=item allow + +A set of criteria used to validate a particular piece of data if it +has to adhere to particular rules. + +See the C function for details. + +=back + +=head1 Functions + +=head2 check( \%tmpl, \%args, [$verbose] ); + +This function is not exported by default, so you'll have to ask for it +via: + + use Params::Check qw[check]; + +or use its fully qualified name instead. + +C takes a list of arguments, as follows: + +=over 4 + +=item Template + +This is a hashreference which contains a template as explained in the +C and C